- Timestamp:
- 2019-12-05T12:06:36+01:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r10742_ENHANCE-12_SimonM-Tides/src/OCE/LBC/lib_mpp.F90
r10538 r12065 32 32 !! ctl_opn : Open file and check if required file is available. 33 33 !! ctl_nam : Prints informations when an error occurs while reading a namelist 34 !! get_unit : give the index of an unused logical unit 35 !!---------------------------------------------------------------------- 36 #if defined key_mpp_mpi 37 !!---------------------------------------------------------------------- 38 !! 'key_mpp_mpi' MPI massively parallel processing library 39 !!---------------------------------------------------------------------- 40 !! lib_mpp_alloc : allocate mpp arrays 41 !! mynode : indentify the processor unit 34 !!---------------------------------------------------------------------- 35 !!---------------------------------------------------------------------- 36 !! mpp_start : get local communicator its size and rank 42 37 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 43 38 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 57 52 !!---------------------------------------------------------------------- 58 53 USE dom_oce ! ocean space and time domain 59 USE lbcnfd ! north fold treatment60 54 USE in_out_manager ! I/O manager 61 55 62 56 IMPLICIT NONE 63 57 PRIVATE 64 65 INTERFACE mpp_nfd66 MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d67 MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr68 END INTERFACE69 70 ! Interface associated to the mpp_lnk_... routines is defined in lbclnk71 PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d72 PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr73 58 ! 74 !!gm this should be useless 75 PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d 76 PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 77 !!gm end 78 ! 79 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 80 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 59 PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam 60 PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free 81 61 PUBLIC mpp_ini_north 82 PUBLIC mpp_lnk_2d_icb83 PUBLIC mpp_lbc_north_icb84 62 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 85 63 PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv … … 87 65 PUBLIC mpp_ini_znl 88 66 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 89 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 67 PUBLIC mpp_report 68 PUBLIC tic_tac 69 #if ! defined key_mpp_mpi 70 PUBLIC MPI_Wtime 71 #endif 90 72 91 73 !! * Interfaces … … 113 95 !! MPI variable definition !! 114 96 !! ========================= !! 97 #if defined key_mpp_mpi 115 98 !$AGRIF_DO_NOT_TREAT 116 99 INCLUDE 'mpif.h' 117 100 !$AGRIF_END_DO_NOT_TREAT 118 119 101 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 102 #else 103 INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 104 INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 105 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 106 #endif 120 107 121 108 INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) … … 146 133 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 147 134 148 ! Type of send : standard, buffered, immediate149 CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)150 LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')151 INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend152 153 135 ! Communications summary report 154 136 CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines … … 160 142 INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic 161 143 INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) 162 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 3000 !: max number of communication record144 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record 163 145 INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc 164 146 INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications … … 176 158 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 177 159 END TYPE DELAYARR 178 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC :: todelay179 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1!: mpi request id of the delayed operations160 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR 161 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations 180 162 181 163 ! timing summary report … … 187 169 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 188 170 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 189 171 190 172 !!---------------------------------------------------------------------- 191 173 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 195 177 CONTAINS 196 178 197 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 198 !!---------------------------------------------------------------------- 199 !! *** routine mynode *** 200 !! 201 !! ** Purpose : Find processor unit 202 !!---------------------------------------------------------------------- 203 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 204 CHARACTER(len=*) , INTENT(in ) :: ldname ! 205 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 206 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 207 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 208 INTEGER , INTENT(inout) :: kstop ! stop indicator 179 SUBROUTINE mpp_start( localComm ) 180 !!---------------------------------------------------------------------- 181 !! *** routine mpp_start *** 182 !! 183 !! ** Purpose : get mpi_comm_oce, mpprank and mppsize 184 !!---------------------------------------------------------------------- 209 185 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 210 186 ! 211 INTEGER :: mynode, ierr, code, ji, ii, ios 212 LOGICAL :: mpi_was_called 213 ! 214 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 215 !!---------------------------------------------------------------------- 216 ! 217 ii = 1 218 WRITE(ldtxt(ii),*) ; ii = ii + 1 219 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 220 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 221 ! 222 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 223 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 224 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 225 ! 226 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 227 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 228 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 229 ! 230 ! ! control print 231 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 232 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 233 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 234 ! 235 IF( jpni < 1 .OR. jpnj < 1 ) THEN 236 WRITE(ldtxt(ii),*) ' jpni and jpnj will be calculated automatically' ; ii = ii + 1 237 ELSE 238 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 239 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 240 ENDIF 241 242 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 243 244 CALL mpi_initialized ( mpi_was_called, code ) 245 IF( code /= MPI_SUCCESS ) THEN 246 DO ji = 1, SIZE(ldtxt) 247 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 248 END DO 249 WRITE(*, cform_err) 250 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 251 CALL mpi_abort( mpi_comm_world, code, ierr ) 252 ENDIF 253 254 IF( mpi_was_called ) THEN 255 ! 256 SELECT CASE ( cn_mpi_send ) 257 CASE ( 'S' ) ! Standard mpi send (blocking) 258 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 259 CASE ( 'B' ) ! Buffer mpi send (blocking) 260 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 261 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 262 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 263 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 264 l_isend = .TRUE. 265 CASE DEFAULT 266 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 267 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 268 kstop = kstop + 1 269 END SELECT 270 ! 271 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 272 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 273 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 274 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 275 kstop = kstop + 1 276 ELSE 277 SELECT CASE ( cn_mpi_send ) 278 CASE ( 'S' ) ! Standard mpi send (blocking) 279 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 280 CALL mpi_init( ierr ) 281 CASE ( 'B' ) ! Buffer mpi send (blocking) 282 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 283 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 284 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 285 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 286 l_isend = .TRUE. 287 CALL mpi_init( ierr ) 288 CASE DEFAULT 289 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 290 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 291 kstop = kstop + 1 292 END SELECT 293 ! 294 ENDIF 295 187 INTEGER :: ierr 188 LOGICAL :: llmpi_init 189 !!---------------------------------------------------------------------- 190 #if defined key_mpp_mpi 191 ! 192 CALL mpi_initialized ( llmpi_init, ierr ) 193 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 194 195 IF( .NOT. llmpi_init ) THEN 196 IF( PRESENT(localComm) ) THEN 197 WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 198 WRITE(ctmp2,*) ' without calling MPI_Init before ! ' 199 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 200 ENDIF 201 CALL mpi_init( ierr ) 202 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 203 ENDIF 204 296 205 IF( PRESENT(localComm) ) THEN 297 206 IF( Agrif_Root() ) THEN … … 299 208 ENDIF 300 209 ELSE 301 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 302 IF( code /= MPI_SUCCESS ) THEN 303 DO ji = 1, SIZE(ldtxt) 304 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 305 END DO 306 WRITE(*, cform_err) 307 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 308 CALL mpi_abort( mpi_comm_world, code, ierr ) 309 ENDIF 310 ENDIF 311 312 #if defined key_agrif 210 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 211 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 212 ENDIF 213 214 # if defined key_agrif 313 215 IF( Agrif_Root() ) THEN 314 216 CALL Agrif_MPI_Init(mpi_comm_oce) … … 316 218 CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 317 219 ENDIF 318 # endif220 # endif 319 221 320 222 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 321 223 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 322 mynode = mpprank323 324 IF( mynode == 0 ) THEN325 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )326 WRITE(kumond, nammpp)327 ENDIF328 224 ! 329 225 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 330 226 ! 331 END FUNCTION mynode 332 333 !!---------------------------------------------------------------------- 334 !! *** routine mpp_lnk_(2,3,4)d *** 335 !! 336 !! * Argument : dummy argument use in mpp_lnk_... routines 337 !! ptab : array or pointer of arrays on which the boundary condition is applied 338 !! cd_nat : nature of array grid-points 339 !! psgn : sign used across the north fold boundary 340 !! kfld : optional, number of pt3d arrays 341 !! cd_mpp : optional, fill the overlap area only 342 !! pval : optional, background value (used at closed boundaries) 343 !!---------------------------------------------------------------------- 344 ! 345 ! !== 2D array and array of 2D pointer ==! 346 ! 347 # define DIM_2d 348 # define ROUTINE_LNK mpp_lnk_2d 349 # include "mpp_lnk_generic.h90" 350 # undef ROUTINE_LNK 351 # define MULTI 352 # define ROUTINE_LNK mpp_lnk_2d_ptr 353 # include "mpp_lnk_generic.h90" 354 # undef ROUTINE_LNK 355 # undef MULTI 356 # undef DIM_2d 357 ! 358 ! !== 3D array and array of 3D pointer ==! 359 ! 360 # define DIM_3d 361 # define ROUTINE_LNK mpp_lnk_3d 362 # include "mpp_lnk_generic.h90" 363 # undef ROUTINE_LNK 364 # define MULTI 365 # define ROUTINE_LNK mpp_lnk_3d_ptr 366 # include "mpp_lnk_generic.h90" 367 # undef ROUTINE_LNK 368 # undef MULTI 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_LNK mpp_lnk_4d 375 # include "mpp_lnk_generic.h90" 376 # undef ROUTINE_LNK 377 # define MULTI 378 # define ROUTINE_LNK mpp_lnk_4d_ptr 379 # include "mpp_lnk_generic.h90" 380 # undef ROUTINE_LNK 381 # undef MULTI 382 # undef DIM_4d 383 384 !!---------------------------------------------------------------------- 385 !! *** routine mpp_nfd_(2,3,4)d *** 386 !! 387 !! * Argument : dummy argument use in mpp_nfd_... routines 388 !! ptab : array or pointer of arrays on which the boundary condition is applied 389 !! cd_nat : nature of array grid-points 390 !! psgn : sign used across the north fold boundary 391 !! kfld : optional, number of pt3d arrays 392 !! cd_mpp : optional, fill the overlap area only 393 !! pval : optional, background value (used at closed boundaries) 394 !!---------------------------------------------------------------------- 395 ! 396 ! !== 2D array and array of 2D pointer ==! 397 ! 398 # define DIM_2d 399 # define ROUTINE_NFD mpp_nfd_2d 400 # include "mpp_nfd_generic.h90" 401 # undef ROUTINE_NFD 402 # define MULTI 403 # define ROUTINE_NFD mpp_nfd_2d_ptr 404 # include "mpp_nfd_generic.h90" 405 # undef ROUTINE_NFD 406 # undef MULTI 407 # undef DIM_2d 408 ! 409 ! !== 3D array and array of 3D pointer ==! 410 ! 411 # define DIM_3d 412 # define ROUTINE_NFD mpp_nfd_3d 413 # include "mpp_nfd_generic.h90" 414 # undef ROUTINE_NFD 415 # define MULTI 416 # define ROUTINE_NFD mpp_nfd_3d_ptr 417 # include "mpp_nfd_generic.h90" 418 # undef ROUTINE_NFD 419 # undef MULTI 420 # undef DIM_3d 421 ! 422 ! !== 4D array and array of 4D pointer ==! 423 ! 424 # define DIM_4d 425 # define ROUTINE_NFD mpp_nfd_4d 426 # include "mpp_nfd_generic.h90" 427 # undef ROUTINE_NFD 428 # define MULTI 429 # define ROUTINE_NFD mpp_nfd_4d_ptr 430 # include "mpp_nfd_generic.h90" 431 # undef ROUTINE_NFD 432 # undef MULTI 433 # undef DIM_4d 434 435 436 !!---------------------------------------------------------------------- 437 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 438 !! 439 !! * Argument : dummy argument use in mpp_lnk_... routines 440 !! ptab : array or pointer of arrays on which the boundary condition is applied 441 !! cd_nat : nature of array grid-points 442 !! psgn : sign used across the north fold boundary 443 !! kb_bdy : BDY boundary set 444 !! kfld : optional, number of pt3d arrays 445 !!---------------------------------------------------------------------- 446 ! 447 ! !== 2D array and array of 2D pointer ==! 448 ! 449 # define DIM_2d 450 # define ROUTINE_BDY mpp_lnk_bdy_2d 451 # include "mpp_bdy_generic.h90" 452 # undef ROUTINE_BDY 453 # undef DIM_2d 454 ! 455 ! !== 3D array and array of 3D pointer ==! 456 ! 457 # define DIM_3d 458 # define ROUTINE_BDY mpp_lnk_bdy_3d 459 # include "mpp_bdy_generic.h90" 460 # undef ROUTINE_BDY 461 # undef DIM_3d 462 ! 463 ! !== 4D array and array of 4D pointer ==! 464 ! 465 # define DIM_4d 466 # define ROUTINE_BDY mpp_lnk_bdy_4d 467 # include "mpp_bdy_generic.h90" 468 # undef ROUTINE_BDY 469 # undef DIM_4d 470 471 !!---------------------------------------------------------------------- 472 !! 473 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 474 475 476 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 477 478 479 !!---------------------------------------------------------------------- 480 227 #else 228 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 229 mppsize = 1 230 mpprank = 0 231 #endif 232 END SUBROUTINE mpp_start 481 233 482 234 … … 497 249 !!---------------------------------------------------------------------- 498 250 ! 499 SELECT CASE ( cn_mpi_send ) 500 CASE ( 'S' ) ! Standard mpi send (blocking) 501 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 502 CASE ( 'B' ) ! Buffer mpi send (blocking) 503 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 504 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 505 ! be carefull, one more argument here : the mpi request identifier.. 506 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 507 END SELECT 251 #if defined key_mpp_mpi 252 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 253 #endif 508 254 ! 509 255 END SUBROUTINE mppsend … … 527 273 !!---------------------------------------------------------------------- 528 274 ! 275 #if defined key_mpp_mpi 529 276 ! If a specific process number has been passed to the receive call, 530 277 ! use that one. Default is to use mpi_any_source … … 533 280 ! 534 281 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 282 #endif 535 283 ! 536 284 END SUBROUTINE mpprecv … … 553 301 ! 554 302 itaille = jpi * jpj 303 #if defined key_mpp_mpi 555 304 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 556 305 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 306 #else 307 pio(:,:,1) = ptab(:,:) 308 #endif 557 309 ! 558 310 END SUBROUTINE mppgather … … 576 328 itaille = jpi * jpj 577 329 ! 330 #if defined key_mpp_mpi 578 331 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & 579 332 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 333 #else 334 ptab(:,:) = pio(:,:,1) 335 #endif 580 336 ! 581 337 END SUBROUTINE mppscatter … … 601 357 COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp 602 358 !!---------------------------------------------------------------------- 359 #if defined key_mpp_mpi 603 360 ilocalcomm = mpi_comm_oce 604 361 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 639 396 640 397 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 641 # if defined key_mpi2398 # if defined key_mpi2 642 399 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 643 400 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 644 401 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 402 # else 403 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 404 # endif 645 405 #else 646 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr)406 pout(:) = REAL(y_in(:), wp) 647 407 #endif 648 408 … … 668 428 INTEGER :: ierr, ilocalcomm 669 429 !!---------------------------------------------------------------------- 430 #if defined key_mpp_mpi 670 431 ilocalcomm = mpi_comm_oce 671 432 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 702 463 703 464 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 704 # if defined key_mpi2465 # if defined key_mpi2 705 466 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 706 467 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 707 468 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 469 # else 470 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 471 # endif 708 472 #else 709 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr)473 pout(:) = p_in(:) 710 474 #endif 711 475 … … 723 487 INTEGER :: ierr 724 488 !!---------------------------------------------------------------------- 489 #if defined key_mpp_mpi 725 490 IF( ndelayid(kid) /= -2 ) THEN 726 491 #if ! defined key_mpi2 … … 732 497 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 733 498 ENDIF 499 #endif 734 500 END SUBROUTINE mpp_delay_rcv 735 501 … … 890 656 !!----------------------------------------------------------------------- 891 657 ! 658 #if defined key_mpp_mpi 892 659 CALL mpi_barrier( mpi_comm_oce, ierror ) 660 #endif 893 661 ! 894 662 END SUBROUTINE mppsync 895 663 896 664 897 SUBROUTINE mppstop( ld final, ld_force_abort )665 SUBROUTINE mppstop( ld_abort ) 898 666 !!---------------------------------------------------------------------- 899 667 !! *** routine mppstop *** … … 902 670 !! 903 671 !!---------------------------------------------------------------------- 904 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 905 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 906 LOGICAL :: llfinal, ll_force_abort 672 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 673 LOGICAL :: ll_abort 907 674 INTEGER :: info 908 675 !!---------------------------------------------------------------------- 909 llfinal = .FALSE. 910 IF( PRESENT(ldfinal) ) llfinal = ldfinal 911 ll_force_abort = .FALSE. 912 IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 913 ! 914 IF(ll_force_abort) THEN 676 ll_abort = .FALSE. 677 IF( PRESENT(ld_abort) ) ll_abort = ld_abort 678 ! 679 #if defined key_mpp_mpi 680 IF(ll_abort) THEN 915 681 CALL mpi_abort( MPI_COMM_WORLD ) 916 682 ELSE … … 918 684 CALL mpi_finalize( info ) 919 685 ENDIF 920 IF( .NOT. llfinal ) STOP 123456 686 #endif 687 IF( ll_abort ) STOP 123 921 688 ! 922 689 END SUBROUTINE mppstop … … 930 697 !!---------------------------------------------------------------------- 931 698 ! 699 #if defined key_mpp_mpi 932 700 CALL MPI_COMM_FREE(kcom, ierr) 701 #endif 933 702 ! 934 703 END SUBROUTINE mpp_comm_free … … 960 729 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 961 730 !!---------------------------------------------------------------------- 731 #if defined key_mpp_mpi 962 732 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 963 733 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world … … 965 735 ! 966 736 ALLOCATE( kwork(jpnij), STAT=ierr ) 967 IF( ierr /= 0 ) THEN 968 WRITE(kumout, cform_err) 969 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 970 CALL mppstop 971 ENDIF 737 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 972 738 973 739 IF( jpnj == 1 ) THEN … … 1031 797 1032 798 DEALLOCATE(kwork) 799 #endif 1033 800 1034 801 END SUBROUTINE mpp_ini_znl … … 1062 829 !!---------------------------------------------------------------------- 1063 830 ! 831 #if defined key_mpp_mpi 1064 832 njmppmax = MAXVAL( njmppt ) 1065 833 ! … … 1093 861 CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 1094 862 ! 863 #endif 1095 864 END SUBROUTINE mpp_ini_north 1096 1097 1098 SUBROUTINE mpi_init_oce( ldtxt, ksft, code )1099 !!---------------------------------------------------------------------1100 !! *** routine mpp_init.opa ***1101 !!1102 !! ** Purpose :: export and attach a MPI buffer for bsend1103 !!1104 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment1105 !! but classical mpi_init1106 !!1107 !! History :: 01/11 :: IDRIS initial version for IBM only1108 !! 08/04 :: R. Benshila, generalisation1109 !!---------------------------------------------------------------------1110 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt1111 INTEGER , INTENT(inout) :: ksft1112 INTEGER , INTENT( out) :: code1113 INTEGER :: ierr, ji1114 LOGICAL :: mpi_was_called1115 !!---------------------------------------------------------------------1116 !1117 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization1118 IF ( code /= MPI_SUCCESS ) THEN1119 DO ji = 1, SIZE(ldtxt)1120 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1121 END DO1122 WRITE(*, cform_err)1123 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'1124 CALL mpi_abort( mpi_comm_world, code, ierr )1125 ENDIF1126 !1127 IF( .NOT. mpi_was_called ) THEN1128 CALL mpi_init( code )1129 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1130 IF ( code /= MPI_SUCCESS ) THEN1131 DO ji = 1, SIZE(ldtxt)1132 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1133 END DO1134 WRITE(*, cform_err)1135 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1136 CALL mpi_abort( mpi_comm_world, code, ierr )1137 ENDIF1138 ENDIF1139 !1140 IF( nn_buffer > 0 ) THEN1141 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11142 ! Buffer allocation and attachment1143 ALLOCATE( tampon(nn_buffer), stat = ierr )1144 IF( ierr /= 0 ) THEN1145 DO ji = 1, SIZE(ldtxt)1146 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1147 END DO1148 WRITE(*, cform_err)1149 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1150 CALL mpi_abort( mpi_comm_world, code, ierr )1151 END IF1152 CALL mpi_buffer_attach( tampon, nn_buffer, code )1153 ENDIF1154 !1155 END SUBROUTINE mpi_init_oce1156 865 1157 866 … … 1187 896 1188 897 1189 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1190 !!---------------------------------------------------------------------1191 !! *** routine mpp_lbc_north_icb ***1192 !!1193 !! ** Purpose : Ensure proper north fold horizontal bondary condition1194 !! in mpp configuration in case of jpn1 > 1 and for 2d1195 !! array with outer extra halo1196 !!1197 !! ** Method : North fold condition and mpp with more than one proc1198 !! in i-direction require a specific treatment. We gather1199 !! the 4+kextj northern lines of the global domain on 11200 !! processor and apply lbc north-fold on this sub array.1201 !! Then we scatter the north fold array back to the processors.1202 !! This routine accounts for an extra halo with icebergs1203 !! and assumes ghost rows and columns have been suppressed.1204 !!1205 !!----------------------------------------------------------------------1206 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1207 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1208 ! ! = T , U , V , F or W -points1209 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1210 !! ! north fold, = 1. otherwise1211 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1212 !1213 INTEGER :: ji, jj, jr1214 INTEGER :: ierr, itaille, ildi, ilei, iilb1215 INTEGER :: ipj, ij, iproc1216 !1217 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1218 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1219 !!----------------------------------------------------------------------1220 !1221 ipj=41222 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1223 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1224 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1225 !1226 ztab_e(:,:) = 0._wp1227 znorthloc_e(:,:) = 0._wp1228 !1229 ij = 1 - kextj1230 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1231 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1232 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1233 ij = ij + 11234 END DO1235 !1236 itaille = jpimax * ( ipj + 2*kextj )1237 !1238 IF( ln_timing ) CALL tic_tac(.TRUE.)1239 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1240 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1241 & ncomm_north, ierr )1242 !1243 IF( ln_timing ) CALL tic_tac(.FALSE.)1244 !1245 DO jr = 1, ndim_rank_north ! recover the global north array1246 iproc = nrank_north(jr) + 11247 ildi = nldit (iproc)1248 ilei = nleit (iproc)1249 iilb = nimppt(iproc)1250 DO jj = 1-kextj, ipj+kextj1251 DO ji = ildi, ilei1252 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1253 END DO1254 END DO1255 END DO1256 1257 ! 2. North-Fold boundary conditions1258 ! ----------------------------------1259 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1260 1261 ij = 1 - kextj1262 !! Scatter back to pt2d1263 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1264 DO ji= 1, jpi1265 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1266 END DO1267 ij = ij +11268 END DO1269 !1270 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1271 !1272 END SUBROUTINE mpp_lbc_north_icb1273 1274 1275 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1276 !!----------------------------------------------------------------------1277 !! *** routine mpp_lnk_2d_icb ***1278 !!1279 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1280 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1281 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1282 !!1283 !! ** Method : Use mppsend and mpprecv function for passing mask1284 !! between processors following neighboring subdomains.1285 !! domain parameters1286 !! jpi : first dimension of the local subdomain1287 !! jpj : second dimension of the local subdomain1288 !! kexti : number of columns for extra outer halo1289 !! kextj : number of rows for extra outer halo1290 !! nbondi : mark for "east-west local boundary"1291 !! nbondj : mark for "north-south local boundary"1292 !! noea : number for local neighboring processors1293 !! nowe : number for local neighboring processors1294 !! noso : number for local neighboring processors1295 !! nono : number for local neighboring processors1296 !!----------------------------------------------------------------------1297 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1298 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1299 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1300 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1301 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1302 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1303 !1304 INTEGER :: jl ! dummy loop indices1305 INTEGER :: imigr, iihom, ijhom ! local integers1306 INTEGER :: ipreci, iprecj ! - -1307 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1308 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1309 !!1310 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1311 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1312 !!----------------------------------------------------------------------1313 1314 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1315 iprecj = nn_hls + kextj1316 1317 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1318 1319 ! 1. standard boundary treatment1320 ! ------------------------------1321 ! Order matters Here !!!!1322 !1323 ! ! East-West boundaries1324 ! !* Cyclic east-west1325 IF( l_Iperio ) THEN1326 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1327 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1328 !1329 ELSE !* closed1330 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1331 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1332 ENDIF1333 ! ! North-South boundaries1334 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1335 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1336 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1337 ELSE !* closed1338 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1339 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1340 ENDIF1341 !1342 1343 ! north fold treatment1344 ! -----------------------1345 IF( npolj /= 0 ) THEN1346 !1347 SELECT CASE ( jpni )1348 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1349 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1350 END SELECT1351 !1352 ENDIF1353 1354 ! 2. East and west directions exchange1355 ! ------------------------------------1356 ! we play with the neigbours AND the row number because of the periodicity1357 !1358 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1359 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1360 iihom = jpi-nreci-kexti1361 DO jl = 1, ipreci1362 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1363 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1364 END DO1365 END SELECT1366 !1367 ! ! Migrations1368 imigr = ipreci * ( jpj + 2*kextj )1369 !1370 IF( ln_timing ) CALL tic_tac(.TRUE.)1371 !1372 SELECT CASE ( nbondi )1373 CASE ( -1 )1374 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1375 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1376 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1377 CASE ( 0 )1378 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1379 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1380 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1381 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1382 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1383 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1384 CASE ( 1 )1385 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1386 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1387 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1388 END SELECT1389 !1390 IF( ln_timing ) CALL tic_tac(.FALSE.)1391 !1392 ! ! Write Dirichlet lateral conditions1393 iihom = jpi - nn_hls1394 !1395 SELECT CASE ( nbondi )1396 CASE ( -1 )1397 DO jl = 1, ipreci1398 pt2d(iihom+jl,:) = r2dew(:,jl,2)1399 END DO1400 CASE ( 0 )1401 DO jl = 1, ipreci1402 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1403 pt2d(iihom+jl,:) = r2dew(:,jl,2)1404 END DO1405 CASE ( 1 )1406 DO jl = 1, ipreci1407 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1408 END DO1409 END SELECT1410 1411 1412 ! 3. North and south directions1413 ! -----------------------------1414 ! always closed : we play only with the neigbours1415 !1416 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1417 ijhom = jpj-nrecj-kextj1418 DO jl = 1, iprecj1419 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1420 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1421 END DO1422 ENDIF1423 !1424 ! ! Migrations1425 imigr = iprecj * ( jpi + 2*kexti )1426 !1427 IF( ln_timing ) CALL tic_tac(.TRUE.)1428 !1429 SELECT CASE ( nbondj )1430 CASE ( -1 )1431 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1432 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1433 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1434 CASE ( 0 )1435 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1436 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1437 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1438 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1439 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1440 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1441 CASE ( 1 )1442 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1443 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1444 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1445 END SELECT1446 !1447 IF( ln_timing ) CALL tic_tac(.FALSE.)1448 !1449 ! ! Write Dirichlet lateral conditions1450 ijhom = jpj - nn_hls1451 !1452 SELECT CASE ( nbondj )1453 CASE ( -1 )1454 DO jl = 1, iprecj1455 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1456 END DO1457 CASE ( 0 )1458 DO jl = 1, iprecj1459 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1460 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1461 END DO1462 CASE ( 1 )1463 DO jl = 1, iprecj1464 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1465 END DO1466 END SELECT1467 !1468 END SUBROUTINE mpp_lnk_2d_icb1469 1470 1471 898 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 1472 899 !!---------------------------------------------------------------------- … … 1480 907 LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg 1481 908 !! 909 CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications 1482 910 LOGICAL :: ll_lbc, ll_glb, ll_dlg 1483 INTEGER :: ji, jj, jk, jh, jf ! dummy loop indices 1484 !!---------------------------------------------------------------------- 911 INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices 912 !!---------------------------------------------------------------------- 913 #if defined key_mpp_mpi 1485 914 ! 1486 915 ll_lbc = .FALSE. … … 1538 967 WRITE(numcom,*) ' ' 1539 968 WRITE(numcom,*) ' lbc_lnk called' 1540 jj = 1 1541 DO ji = 2, n_sequence_lbc 1542 IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 1543 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 1544 jj = 0 969 DO ji = 1, n_sequence_lbc - 1 970 IF ( crname_lbc(ji) /= 'already counted' ) THEN 971 ccountname = crname_lbc(ji) 972 crname_lbc(ji) = 'already counted' 973 jcount = 1 974 DO jj = ji + 1, n_sequence_lbc 975 IF ( ccountname == crname_lbc(jj) ) THEN 976 jcount = jcount + 1 977 crname_lbc(jj) = 'already counted' 978 END IF 979 END DO 980 WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) 1545 981 END IF 1546 jj = jj + 11547 982 END DO 1548 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 983 IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 984 WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 985 END IF 1549 986 WRITE(numcom,*) ' ' 1550 987 IF ( n_sequence_glb > 0 ) THEN … … 1585 1022 DEALLOCATE(crname_lbc) 1586 1023 ENDIF 1024 #endif 1587 1025 END SUBROUTINE mpp_report 1588 1026 … … 1595 1033 REAL(wp), SAVE :: tic_ct = 0._wp 1596 1034 INTEGER :: ii 1035 #if defined key_mpp_mpi 1597 1036 1598 1037 IF( ncom_stp <= nit000 ) RETURN … … 1610 1049 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1611 1050 ENDIF 1051 #endif 1612 1052 1613 1053 END SUBROUTINE tic_tac 1614 1054 1055 #if ! defined key_mpp_mpi 1056 SUBROUTINE mpi_wait(request, status, ierror) 1057 INTEGER , INTENT(in ) :: request 1058 INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status 1059 INTEGER , INTENT( out) :: ierror 1060 END SUBROUTINE mpi_wait 1061 1615 1062 1616 #else 1617 !!---------------------------------------------------------------------- 1618 !! Default case: Dummy module share memory computing 1619 !!---------------------------------------------------------------------- 1620 USE in_out_manager 1621 1622 INTERFACE mpp_sum 1623 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1624 END INTERFACE 1625 INTERFACE mpp_max 1626 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 1627 END INTERFACE 1628 INTERFACE mpp_min 1629 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 1630 END INTERFACE 1631 INTERFACE mpp_minloc 1632 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 1633 END INTERFACE 1634 INTERFACE mpp_maxloc 1635 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1636 END INTERFACE 1637 1638 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 1639 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 1640 INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator 1641 1642 INTEGER, PARAMETER, PUBLIC :: nbdelay = 0 ! make sure we don't enter loops: DO ji = 1, nbdelay 1643 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaylist = 'empty' 1644 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaycpnt = 'empty' 1645 LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. 1646 TYPE :: DELAYARR 1647 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 1648 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 1649 END TYPE DELAYARR 1650 TYPE( DELAYARR ), DIMENSION(1), PUBLIC :: todelay 1651 INTEGER, PUBLIC, DIMENSION(1) :: ndelayid = -1 1652 !!---------------------------------------------------------------------- 1653 CONTAINS 1654 1655 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 1656 INTEGER, INTENT(in) :: kumout 1657 lib_mpp_alloc = 0 1658 END FUNCTION lib_mpp_alloc 1659 1660 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 1661 INTEGER, OPTIONAL , INTENT(in ) :: localComm 1662 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1663 CHARACTER(len=*) :: ldname 1664 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1665 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 1666 function_value = 0 1667 IF( .FALSE. ) ldtxt(:) = 'never done' 1668 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 1669 END FUNCTION mynode 1670 1671 SUBROUTINE mppsync ! Dummy routine 1672 END SUBROUTINE mppsync 1673 1674 !!---------------------------------------------------------------------- 1675 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1676 !! 1677 !!---------------------------------------------------------------------- 1678 !! 1679 # define OPERATION_MAX 1680 # define INTEGER_TYPE 1681 # define DIM_0d 1682 # define ROUTINE_ALLREDUCE mppmax_int 1683 # include "mpp_allreduce_generic.h90" 1684 # undef ROUTINE_ALLREDUCE 1685 # undef DIM_0d 1686 # define DIM_1d 1687 # define ROUTINE_ALLREDUCE mppmax_a_int 1688 # include "mpp_allreduce_generic.h90" 1689 # undef ROUTINE_ALLREDUCE 1690 # undef DIM_1d 1691 # undef INTEGER_TYPE 1692 ! 1693 # define REAL_TYPE 1694 # define DIM_0d 1695 # define ROUTINE_ALLREDUCE mppmax_real 1696 # include "mpp_allreduce_generic.h90" 1697 # undef ROUTINE_ALLREDUCE 1698 # undef DIM_0d 1699 # define DIM_1d 1700 # define ROUTINE_ALLREDUCE mppmax_a_real 1701 # include "mpp_allreduce_generic.h90" 1702 # undef ROUTINE_ALLREDUCE 1703 # undef DIM_1d 1704 # undef REAL_TYPE 1705 # undef OPERATION_MAX 1706 !!---------------------------------------------------------------------- 1707 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1708 !! 1709 !!---------------------------------------------------------------------- 1710 !! 1711 # define OPERATION_MIN 1712 # define INTEGER_TYPE 1713 # define DIM_0d 1714 # define ROUTINE_ALLREDUCE mppmin_int 1715 # include "mpp_allreduce_generic.h90" 1716 # undef ROUTINE_ALLREDUCE 1717 # undef DIM_0d 1718 # define DIM_1d 1719 # define ROUTINE_ALLREDUCE mppmin_a_int 1720 # include "mpp_allreduce_generic.h90" 1721 # undef ROUTINE_ALLREDUCE 1722 # undef DIM_1d 1723 # undef INTEGER_TYPE 1724 ! 1725 # define REAL_TYPE 1726 # define DIM_0d 1727 # define ROUTINE_ALLREDUCE mppmin_real 1728 # include "mpp_allreduce_generic.h90" 1729 # undef ROUTINE_ALLREDUCE 1730 # undef DIM_0d 1731 # define DIM_1d 1732 # define ROUTINE_ALLREDUCE mppmin_a_real 1733 # include "mpp_allreduce_generic.h90" 1734 # undef ROUTINE_ALLREDUCE 1735 # undef DIM_1d 1736 # undef REAL_TYPE 1737 # undef OPERATION_MIN 1738 1739 !!---------------------------------------------------------------------- 1740 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1741 !! 1742 !! Global sum of 1D array or a variable (integer, real or complex) 1743 !!---------------------------------------------------------------------- 1744 !! 1745 # define OPERATION_SUM 1746 # define INTEGER_TYPE 1747 # define DIM_0d 1748 # define ROUTINE_ALLREDUCE mppsum_int 1749 # include "mpp_allreduce_generic.h90" 1750 # undef ROUTINE_ALLREDUCE 1751 # undef DIM_0d 1752 # define DIM_1d 1753 # define ROUTINE_ALLREDUCE mppsum_a_int 1754 # include "mpp_allreduce_generic.h90" 1755 # undef ROUTINE_ALLREDUCE 1756 # undef DIM_1d 1757 # undef INTEGER_TYPE 1758 ! 1759 # define REAL_TYPE 1760 # define DIM_0d 1761 # define ROUTINE_ALLREDUCE mppsum_real 1762 # include "mpp_allreduce_generic.h90" 1763 # undef ROUTINE_ALLREDUCE 1764 # undef DIM_0d 1765 # define DIM_1d 1766 # define ROUTINE_ALLREDUCE mppsum_a_real 1767 # include "mpp_allreduce_generic.h90" 1768 # undef ROUTINE_ALLREDUCE 1769 # undef DIM_1d 1770 # undef REAL_TYPE 1771 # undef OPERATION_SUM 1772 1773 # define OPERATION_SUM_DD 1774 # define COMPLEX_TYPE 1775 # define DIM_0d 1776 # define ROUTINE_ALLREDUCE mppsum_realdd 1777 # include "mpp_allreduce_generic.h90" 1778 # undef ROUTINE_ALLREDUCE 1779 # undef DIM_0d 1780 # define DIM_1d 1781 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1782 # include "mpp_allreduce_generic.h90" 1783 # undef ROUTINE_ALLREDUCE 1784 # undef DIM_1d 1785 # undef COMPLEX_TYPE 1786 # undef OPERATION_SUM_DD 1787 1788 !!---------------------------------------------------------------------- 1789 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1790 !! 1791 !!---------------------------------------------------------------------- 1792 !! 1793 # define OPERATION_MINLOC 1794 # define DIM_2d 1795 # define ROUTINE_LOC mpp_minloc2d 1796 # include "mpp_loc_generic.h90" 1797 # undef ROUTINE_LOC 1798 # undef DIM_2d 1799 # define DIM_3d 1800 # define ROUTINE_LOC mpp_minloc3d 1801 # include "mpp_loc_generic.h90" 1802 # undef ROUTINE_LOC 1803 # undef DIM_3d 1804 # undef OPERATION_MINLOC 1805 1806 # define OPERATION_MAXLOC 1807 # define DIM_2d 1808 # define ROUTINE_LOC mpp_maxloc2d 1809 # include "mpp_loc_generic.h90" 1810 # undef ROUTINE_LOC 1811 # undef DIM_2d 1812 # define DIM_3d 1813 # define ROUTINE_LOC mpp_maxloc3d 1814 # include "mpp_loc_generic.h90" 1815 # undef ROUTINE_LOC 1816 # undef DIM_3d 1817 # undef OPERATION_MAXLOC 1818 1819 SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 1820 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1821 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1822 COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in 1823 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1824 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1825 INTEGER, INTENT(in ), OPTIONAL :: kcom 1826 ! 1827 pout(:) = REAL(y_in(:), wp) 1828 END SUBROUTINE mpp_delay_sum 1829 1830 SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 1831 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1832 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1833 REAL(wp), INTENT(in ), DIMENSION(:) :: p_in 1834 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1835 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1836 INTEGER, INTENT(in ), OPTIONAL :: kcom 1837 ! 1838 pout(:) = p_in(:) 1839 END SUBROUTINE mpp_delay_max 1840 1841 SUBROUTINE mpp_delay_rcv( kid ) 1842 INTEGER,INTENT(in ) :: kid 1843 WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 1844 END SUBROUTINE mpp_delay_rcv 1845 1846 SUBROUTINE mppstop( ldfinal, ld_force_abort ) 1847 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 1848 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 1849 STOP ! non MPP case, just stop the run 1850 END SUBROUTINE mppstop 1851 1852 SUBROUTINE mpp_ini_znl( knum ) 1853 INTEGER :: knum 1854 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 1855 END SUBROUTINE mpp_ini_znl 1856 1857 SUBROUTINE mpp_comm_free( kcom ) 1858 INTEGER :: kcom 1859 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 1860 END SUBROUTINE mpp_comm_free 1861 1862 #endif 1863 1864 !!---------------------------------------------------------------------- 1865 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1063 FUNCTION MPI_Wtime() 1064 REAL(wp) :: MPI_Wtime 1065 MPI_Wtime = -1. 1066 END FUNCTION MPI_Wtime 1067 #endif 1068 1069 !!---------------------------------------------------------------------- 1070 !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1866 1071 !!---------------------------------------------------------------------- 1867 1072 … … 1874 1079 !! increment the error number (nstop) by one. 1875 1080 !!---------------------------------------------------------------------- 1876 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 1877 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1081 CHARACTER(len=*), INTENT(in ) :: cd1 1082 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1083 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1878 1084 !!---------------------------------------------------------------------- 1879 1085 ! 1880 1086 nstop = nstop + 1 1881 1882 ! force to open ocean.output file 1087 ! 1088 ! force to open ocean.output file if not already opened 1883 1089 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1884 1885 WRITE(numout,cform_err) 1886 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1090 ! 1091 WRITE(numout,*) 1092 WRITE(numout,*) ' ===>>> : E R R O R' 1093 WRITE(numout,*) 1094 WRITE(numout,*) ' ===========' 1095 WRITE(numout,*) 1096 WRITE(numout,*) TRIM(cd1) 1887 1097 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1888 1098 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1894 1104 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1895 1105 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1896 1106 WRITE(numout,*) 1107 ! 1897 1108 CALL FLUSH(numout ) 1898 1109 IF( numstp /= -1 ) CALL FLUSH(numstp ) … … 1901 1112 ! 1902 1113 IF( cd1 == 'STOP' ) THEN 1114 WRITE(numout,*) 1903 1115 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1904 CALL mppstop(ld_force_abort = .true.) 1116 WRITE(numout,*) 1117 CALL mppstop( ld_abort = .true. ) 1905 1118 ENDIF 1906 1119 ! … … 1921 1134 ! 1922 1135 nwarn = nwarn + 1 1136 ! 1923 1137 IF(lwp) THEN 1924 WRITE(numout,cform_war) 1925 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1926 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1927 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1928 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1929 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1930 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1931 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1932 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1933 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1934 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1138 WRITE(numout,*) 1139 WRITE(numout,*) ' ===>>> : W A R N I N G' 1140 WRITE(numout,*) 1141 WRITE(numout,*) ' ===============' 1142 WRITE(numout,*) 1143 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1144 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1145 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1146 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1147 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1148 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1149 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1150 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1151 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1152 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1153 WRITE(numout,*) 1935 1154 ENDIF 1936 1155 CALL FLUSH(numout) … … 1975 1194 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1976 1195 ! 1977 iost=0 1978 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1196 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1979 1197 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1980 1198 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 1997 1215 100 CONTINUE 1998 1216 IF( iost /= 0 ) THEN 1999 IF(ldwp) THEN 2000 WRITE(kout,*) 2001 WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2002 WRITE(kout,*) ' ======= === ' 2003 WRITE(kout,*) ' unit = ', knum 2004 WRITE(kout,*) ' status = ', cdstat 2005 WRITE(kout,*) ' form = ', cdform 2006 WRITE(kout,*) ' access = ', cdacce 2007 WRITE(kout,*) ' iostat = ', iost 2008 WRITE(kout,*) ' we stop. verify the file ' 2009 WRITE(kout,*) 2010 ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 2011 WRITE(*,*) 2012 WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2013 WRITE(*,*) ' ======= === ' 2014 WRITE(*,*) ' unit = ', knum 2015 WRITE(*,*) ' status = ', cdstat 2016 WRITE(*,*) ' form = ', cdform 2017 WRITE(*,*) ' access = ', cdacce 2018 WRITE(*,*) ' iostat = ', iost 2019 WRITE(*,*) ' we stop. verify the file ' 2020 WRITE(*,*) 2021 ENDIF 2022 CALL FLUSH( kout ) 2023 STOP 'ctl_opn bad opening' 1217 WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1218 WRITE(ctmp2,*) ' ======= === ' 1219 WRITE(ctmp3,*) ' unit = ', knum 1220 WRITE(ctmp4,*) ' status = ', cdstat 1221 WRITE(ctmp5,*) ' form = ', cdform 1222 WRITE(ctmp6,*) ' access = ', cdacce 1223 WRITE(ctmp7,*) ' iostat = ', iost 1224 WRITE(ctmp8,*) ' we stop. verify the file ' 1225 CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 2024 1226 ENDIF 2025 1227 ! … … 2027 1229 2028 1230 2029 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1231 SUBROUTINE ctl_nam ( kios, cdnam ) 2030 1232 !!---------------------------------------------------------------------- 2031 1233 !! *** ROUTINE ctl_nam *** … … 2035 1237 !! ** Method : Fortan open 2036 1238 !!---------------------------------------------------------------------- 2037 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist2038 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs2039 CHARACTER(len=5) :: clios ! string to convert iostat in character for print2040 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1239 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 1240 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 1241 ! 1242 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 2041 1243 !!---------------------------------------------------------------------- 2042 1244 ! … … 2052 1254 ENDIF 2053 1255 kios = 0 2054 RETURN2055 1256 ! 2056 1257 END SUBROUTINE ctl_nam … … 2073 1274 END DO 2074 1275 IF( (get_unit == 999) .AND. llopn ) THEN 2075 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 2076 get_unit = -1 1276 CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 2077 1277 ENDIF 2078 1278 !
Note: See TracChangeset
for help on using the changeset viewer.