Changeset 11822 for NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lib_mpp.F90
- Timestamp:
- 2019-10-29T11:41:36+01:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lib_mpp.F90
r11504 r11822 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 … … 159 141 INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic 160 142 INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos) 161 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 3000 !: max number of communication record143 INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record 162 144 INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc 163 145 INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications … … 175 157 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 176 158 END TYPE DELAYARR 177 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC :: todelay178 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1!: mpi request id of the delayed operations159 TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR 160 INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations 179 161 180 162 ! timing summary report … … 186 168 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 187 169 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 188 170 189 171 !!---------------------------------------------------------------------- 190 172 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 194 176 CONTAINS 195 177 196 FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 197 !!---------------------------------------------------------------------- 198 !! *** routine mynode *** 199 !! 200 !! ** Purpose : Find processor unit 201 !!---------------------------------------------------------------------- 202 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 203 CHARACTER(len=*) , INTENT(in ) :: ldname ! 204 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 205 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 206 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 207 INTEGER , INTENT(inout) :: kstop ! stop indicator 178 SUBROUTINE mpp_start( localComm ) 179 !!---------------------------------------------------------------------- 180 !! *** routine mpp_start *** 181 !! 182 !! ** Purpose : get mpi_comm_oce, mpprank and mppsize 183 !!---------------------------------------------------------------------- 208 184 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 209 185 ! 210 INTEGER :: mynode, ierr, code, ji, ii, ios 211 LOGICAL :: mpi_was_called 212 ! 213 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 214 !!---------------------------------------------------------------------- 215 ! 216 ii = 1 217 WRITE(ldtxt(ii),*) ; ii = ii + 1 218 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 219 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 220 ! 221 REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables 222 READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 223 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 224 ! 225 REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables 226 READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 227 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 228 ! 229 ! ! control print 230 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 231 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 232 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 233 ! 234 IF( jpni < 1 .OR. jpnj < 1 ) THEN 235 WRITE(ldtxt(ii),*) ' jpni and jpnj will be calculated automatically' ; ii = ii + 1 236 ELSE 237 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 238 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 239 ENDIF 240 241 WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1 242 243 CALL mpi_initialized ( mpi_was_called, code ) 244 IF( code /= MPI_SUCCESS ) THEN 245 DO ji = 1, SIZE(ldtxt) 246 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 247 END DO 248 WRITE(*, cform_err) 249 WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 250 CALL mpi_abort( mpi_comm_world, code, ierr ) 251 ENDIF 252 253 IF( mpi_was_called ) THEN 254 ! 255 SELECT CASE ( cn_mpi_send ) 256 CASE ( 'S' ) ! Standard mpi send (blocking) 257 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 258 CASE ( 'B' ) ! Buffer mpi send (blocking) 259 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 260 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 261 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 262 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 263 l_isend = .TRUE. 264 CASE DEFAULT 265 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 266 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 267 kstop = kstop + 1 268 END SELECT 269 ! 270 ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 271 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 272 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 273 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 274 kstop = kstop + 1 275 ELSE 276 SELECT CASE ( cn_mpi_send ) 277 CASE ( 'S' ) ! Standard mpi send (blocking) 278 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 279 CALL mpi_init( ierr ) 280 CASE ( 'B' ) ! Buffer mpi send (blocking) 281 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 282 IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr ) 283 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 284 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 285 l_isend = .TRUE. 286 CALL mpi_init( ierr ) 287 CASE DEFAULT 288 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 289 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 290 kstop = kstop + 1 291 END SELECT 292 ! 293 ENDIF 294 186 INTEGER :: ierr 187 LOGICAL :: llmpi_init 188 !!---------------------------------------------------------------------- 189 #if defined key_mpp_mpi 190 ! 191 CALL mpi_initialized ( llmpi_init, ierr ) 192 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 193 194 IF( .NOT. llmpi_init ) THEN 195 IF( PRESENT(localComm) ) THEN 196 WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 197 WRITE(ctmp2,*) ' without calling MPI_Init before ! ' 198 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 199 ENDIF 200 CALL mpi_init( ierr ) 201 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 202 ENDIF 203 295 204 IF( PRESENT(localComm) ) THEN 296 205 IF( Agrif_Root() ) THEN … … 298 207 ENDIF 299 208 ELSE 300 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 301 IF( code /= MPI_SUCCESS ) THEN 302 DO ji = 1, SIZE(ldtxt) 303 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode 304 END DO 305 WRITE(*, cform_err) 306 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 307 CALL mpi_abort( mpi_comm_world, code, ierr ) 308 ENDIF 309 ENDIF 310 311 #if defined key_agrif 209 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 210 IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 211 ENDIF 212 213 # if defined key_agrif 312 214 IF( Agrif_Root() ) THEN 313 215 CALL Agrif_MPI_Init(mpi_comm_oce) … … 315 217 CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 316 218 ENDIF 317 # endif219 # endif 318 220 319 221 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 320 222 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 321 mynode = mpprank322 323 IF( mynode == 0 ) THEN324 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )325 WRITE(kumond, nammpp)326 ENDIF327 223 ! 328 224 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 329 225 ! 330 END FUNCTION mynode 331 332 !!---------------------------------------------------------------------- 333 !! *** routine mpp_lnk_(2,3,4)d *** 334 !! 335 !! * Argument : dummy argument use in mpp_lnk_... routines 336 !! ptab : array or pointer of arrays on which the boundary condition is applied 337 !! cd_nat : nature of array grid-points 338 !! psgn : sign used across the north fold boundary 339 !! kfld : optional, number of pt3d arrays 340 !! cd_mpp : optional, fill the overlap area only 341 !! pval : optional, background value (used at closed boundaries) 342 !!---------------------------------------------------------------------- 343 ! 344 ! !== 2D array and array of 2D pointer ==! 345 ! 346 # define DIM_2d 347 # define ROUTINE_LNK mpp_lnk_2d 348 # include "mpp_lnk_generic.h90" 349 # undef ROUTINE_LNK 350 # define MULTI 351 # define ROUTINE_LNK mpp_lnk_2d_ptr 352 # include "mpp_lnk_generic.h90" 353 # undef ROUTINE_LNK 354 # undef MULTI 355 # undef DIM_2d 356 ! 357 ! !== 3D array and array of 3D pointer ==! 358 ! 359 # define DIM_3d 360 # define ROUTINE_LNK mpp_lnk_3d 361 # include "mpp_lnk_generic.h90" 362 # undef ROUTINE_LNK 363 # define MULTI 364 # define ROUTINE_LNK mpp_lnk_3d_ptr 365 # include "mpp_lnk_generic.h90" 366 # undef ROUTINE_LNK 367 # undef MULTI 368 # undef DIM_3d 369 ! 370 ! !== 4D array and array of 4D pointer ==! 371 ! 372 # define DIM_4d 373 # define ROUTINE_LNK mpp_lnk_4d 374 # include "mpp_lnk_generic.h90" 375 # undef ROUTINE_LNK 376 # define MULTI 377 # define ROUTINE_LNK mpp_lnk_4d_ptr 378 # include "mpp_lnk_generic.h90" 379 # undef ROUTINE_LNK 380 # undef MULTI 381 # undef DIM_4d 382 383 !!---------------------------------------------------------------------- 384 !! *** routine mpp_nfd_(2,3,4)d *** 385 !! 386 !! * Argument : dummy argument use in mpp_nfd_... routines 387 !! ptab : array or pointer of arrays on which the boundary condition is applied 388 !! cd_nat : nature of array grid-points 389 !! psgn : sign used across the north fold boundary 390 !! kfld : optional, number of pt3d arrays 391 !! cd_mpp : optional, fill the overlap area only 392 !! pval : optional, background value (used at closed boundaries) 393 !!---------------------------------------------------------------------- 394 ! 395 ! !== 2D array and array of 2D pointer ==! 396 ! 397 # define DIM_2d 398 # define ROUTINE_NFD mpp_nfd_2d 399 # include "mpp_nfd_generic.h90" 400 # undef ROUTINE_NFD 401 # define MULTI 402 # define ROUTINE_NFD mpp_nfd_2d_ptr 403 # include "mpp_nfd_generic.h90" 404 # undef ROUTINE_NFD 405 # undef MULTI 406 # undef DIM_2d 407 ! 408 ! !== 3D array and array of 3D pointer ==! 409 ! 410 # define DIM_3d 411 # define ROUTINE_NFD mpp_nfd_3d 412 # include "mpp_nfd_generic.h90" 413 # undef ROUTINE_NFD 414 # define MULTI 415 # define ROUTINE_NFD mpp_nfd_3d_ptr 416 # include "mpp_nfd_generic.h90" 417 # undef ROUTINE_NFD 418 # undef MULTI 419 # undef DIM_3d 420 ! 421 ! !== 4D array and array of 4D pointer ==! 422 ! 423 # define DIM_4d 424 # define ROUTINE_NFD mpp_nfd_4d 425 # include "mpp_nfd_generic.h90" 426 # undef ROUTINE_NFD 427 # define MULTI 428 # define ROUTINE_NFD mpp_nfd_4d_ptr 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # undef MULTI 432 # undef DIM_4d 433 434 435 !!---------------------------------------------------------------------- 436 !! *** routine mpp_lnk_bdy_(2,3,4)d *** 437 !! 438 !! * Argument : dummy argument use in mpp_lnk_... routines 439 !! ptab : array or pointer of arrays on which the boundary condition is applied 440 !! cd_nat : nature of array grid-points 441 !! psgn : sign used across the north fold boundary 442 !! kb_bdy : BDY boundary set 443 !! kfld : optional, number of pt3d arrays 444 !!---------------------------------------------------------------------- 445 ! 446 ! !== 2D array and array of 2D pointer ==! 447 ! 448 # define DIM_2d 449 # define ROUTINE_BDY mpp_lnk_bdy_2d 450 # include "mpp_bdy_generic.h90" 451 # undef ROUTINE_BDY 452 # undef DIM_2d 453 ! 454 ! !== 3D array and array of 3D pointer ==! 455 ! 456 # define DIM_3d 457 # define ROUTINE_BDY mpp_lnk_bdy_3d 458 # include "mpp_bdy_generic.h90" 459 # undef ROUTINE_BDY 460 # undef DIM_3d 461 ! 462 ! !== 4D array and array of 4D pointer ==! 463 ! 464 # define DIM_4d 465 # define ROUTINE_BDY mpp_lnk_bdy_4d 466 # include "mpp_bdy_generic.h90" 467 # undef ROUTINE_BDY 468 # undef DIM_4d 469 470 !!---------------------------------------------------------------------- 471 !! 472 !! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D 473 474 475 !! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!! 476 477 478 !!---------------------------------------------------------------------- 479 226 #else 227 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 228 mppsize = 1 229 mpprank = 0 230 #endif 231 END SUBROUTINE mpp_start 480 232 481 233 … … 496 248 !!---------------------------------------------------------------------- 497 249 ! 498 SELECT CASE ( cn_mpi_send ) 499 CASE ( 'S' ) ! Standard mpi send (blocking) 500 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 501 CASE ( 'B' ) ! Buffer mpi send (blocking) 502 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag ) 503 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 504 ! be carefull, one more argument here : the mpi request identifier.. 505 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 506 END SELECT 250 #if defined key_mpp_mpi 251 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 252 #endif 507 253 ! 508 254 END SUBROUTINE mppsend … … 526 272 !!---------------------------------------------------------------------- 527 273 ! 274 #if defined key_mpp_mpi 528 275 ! If a specific process number has been passed to the receive call, 529 276 ! use that one. Default is to use mpi_any_source … … 532 279 ! 533 280 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 281 #endif 534 282 ! 535 283 END SUBROUTINE mpprecv … … 552 300 ! 553 301 itaille = jpi * jpj 302 #if defined key_mpp_mpi 554 303 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & 555 304 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 305 #else 306 pio(:,:,1) = ptab(:,:) 307 #endif 556 308 ! 557 309 END SUBROUTINE mppgather … … 575 327 itaille = jpi * jpj 576 328 ! 329 #if defined key_mpp_mpi 577 330 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & 578 331 & mpi_double_precision, kp , mpi_comm_oce, ierror ) 332 #else 333 ptab(:,:) = pio(:,:,1) 334 #endif 579 335 ! 580 336 END SUBROUTINE mppscatter … … 600 356 COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp 601 357 !!---------------------------------------------------------------------- 358 #if defined key_mpp_mpi 602 359 ilocalcomm = mpi_comm_oce 603 360 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 638 395 639 396 ! send y_in into todelay(idvar)%y1d with a non-blocking communication 640 # if defined key_mpi2397 # if defined key_mpi2 641 398 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 642 399 CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 643 400 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 401 # else 402 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 403 # endif 644 404 #else 645 CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr)405 pout(:) = REAL(y_in(:), wp) 646 406 #endif 647 407 … … 667 427 INTEGER :: ierr, ilocalcomm 668 428 !!---------------------------------------------------------------------- 429 #if defined key_mpp_mpi 669 430 ilocalcomm = mpi_comm_oce 670 431 IF( PRESENT(kcom) ) ilocalcomm = kcom … … 701 462 702 463 ! send p_in into todelay(idvar)%z1d with a non-blocking communication 703 # if defined key_mpi2464 # if defined key_mpi2 704 465 IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 705 466 CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 706 467 IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 468 # else 469 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 470 # endif 707 471 #else 708 CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr)472 pout(:) = p_in(:) 709 473 #endif 710 474 … … 722 486 INTEGER :: ierr 723 487 !!---------------------------------------------------------------------- 488 #if defined key_mpp_mpi 724 489 IF( ndelayid(kid) /= -2 ) THEN 725 490 #if ! defined key_mpi2 … … 731 496 ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid 732 497 ENDIF 498 #endif 733 499 END SUBROUTINE mpp_delay_rcv 734 500 … … 889 655 !!----------------------------------------------------------------------- 890 656 ! 657 #if defined key_mpp_mpi 891 658 CALL mpi_barrier( mpi_comm_oce, ierror ) 659 #endif 892 660 ! 893 661 END SUBROUTINE mppsync 894 662 895 663 896 SUBROUTINE mppstop( ld final, ld_force_abort )664 SUBROUTINE mppstop( ld_abort ) 897 665 !!---------------------------------------------------------------------- 898 666 !! *** routine mppstop *** … … 901 669 !! 902 670 !!---------------------------------------------------------------------- 903 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 904 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 905 LOGICAL :: llfinal, ll_force_abort 671 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 672 LOGICAL :: ll_abort 906 673 INTEGER :: info 907 674 !!---------------------------------------------------------------------- 908 llfinal = .FALSE. 909 IF( PRESENT(ldfinal) ) llfinal = ldfinal 910 ll_force_abort = .FALSE. 911 IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 912 ! 913 IF(ll_force_abort) THEN 675 ll_abort = .FALSE. 676 IF( PRESENT(ld_abort) ) ll_abort = ld_abort 677 ! 678 #if defined key_mpp_mpi 679 IF(ll_abort) THEN 914 680 CALL mpi_abort( MPI_COMM_WORLD ) 915 681 ELSE … … 917 683 CALL mpi_finalize( info ) 918 684 ENDIF 919 IF( .NOT. llfinal ) STOP 123456 685 #endif 686 IF( ll_abort ) STOP 123 920 687 ! 921 688 END SUBROUTINE mppstop … … 929 696 !!---------------------------------------------------------------------- 930 697 ! 698 #if defined key_mpp_mpi 931 699 CALL MPI_COMM_FREE(kcom, ierr) 700 #endif 932 701 ! 933 702 END SUBROUTINE mpp_comm_free … … 959 728 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 960 729 !!---------------------------------------------------------------------- 730 #if defined key_mpp_mpi 961 731 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 962 732 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world … … 964 734 ! 965 735 ALLOCATE( kwork(jpnij), STAT=ierr ) 966 IF( ierr /= 0 ) THEN 967 WRITE(kumout, cform_err) 968 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 969 CALL mppstop 970 ENDIF 736 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 971 737 972 738 IF( jpnj == 1 ) THEN … … 1030 796 1031 797 DEALLOCATE(kwork) 798 #endif 1032 799 1033 800 END SUBROUTINE mpp_ini_znl … … 1061 828 !!---------------------------------------------------------------------- 1062 829 ! 830 #if defined key_mpp_mpi 1063 831 njmppmax = MAXVAL( njmppt ) 1064 832 ! … … 1092 860 CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 1093 861 ! 862 #endif 1094 863 END SUBROUTINE mpp_ini_north 1095 1096 1097 SUBROUTINE mpi_init_oce( ldtxt, ksft, code )1098 !!---------------------------------------------------------------------1099 !! *** routine mpp_init.opa ***1100 !!1101 !! ** Purpose :: export and attach a MPI buffer for bsend1102 !!1103 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment1104 !! but classical mpi_init1105 !!1106 !! History :: 01/11 :: IDRIS initial version for IBM only1107 !! 08/04 :: R. Benshila, generalisation1108 !!---------------------------------------------------------------------1109 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt1110 INTEGER , INTENT(inout) :: ksft1111 INTEGER , INTENT( out) :: code1112 INTEGER :: ierr, ji1113 LOGICAL :: mpi_was_called1114 !!---------------------------------------------------------------------1115 !1116 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization1117 IF ( code /= MPI_SUCCESS ) THEN1118 DO ji = 1, SIZE(ldtxt)1119 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1120 END DO1121 WRITE(*, cform_err)1122 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'1123 CALL mpi_abort( mpi_comm_world, code, ierr )1124 ENDIF1125 !1126 IF( .NOT. mpi_was_called ) THEN1127 CALL mpi_init( code )1128 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1129 IF ( code /= MPI_SUCCESS ) THEN1130 DO ji = 1, SIZE(ldtxt)1131 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1132 END DO1133 WRITE(*, cform_err)1134 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1135 CALL mpi_abort( mpi_comm_world, code, ierr )1136 ENDIF1137 ENDIF1138 !1139 IF( nn_buffer > 0 ) THEN1140 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11141 ! Buffer allocation and attachment1142 ALLOCATE( tampon(nn_buffer), stat = ierr )1143 IF( ierr /= 0 ) THEN1144 DO ji = 1, SIZE(ldtxt)1145 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1146 END DO1147 WRITE(*, cform_err)1148 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1149 CALL mpi_abort( mpi_comm_world, code, ierr )1150 END IF1151 CALL mpi_buffer_attach( tampon, nn_buffer, code )1152 ENDIF1153 !1154 END SUBROUTINE mpi_init_oce1155 864 1156 865 … … 1186 895 1187 896 1188 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)1189 !!---------------------------------------------------------------------1190 !! *** routine mpp_lbc_north_icb ***1191 !!1192 !! ** Purpose : Ensure proper north fold horizontal bondary condition1193 !! in mpp configuration in case of jpn1 > 1 and for 2d1194 !! array with outer extra halo1195 !!1196 !! ** Method : North fold condition and mpp with more than one proc1197 !! in i-direction require a specific treatment. We gather1198 !! the 4+kextj northern lines of the global domain on 11199 !! processor and apply lbc north-fold on this sub array.1200 !! Then we scatter the north fold array back to the processors.1201 !! This routine accounts for an extra halo with icebergs1202 !! and assumes ghost rows and columns have been suppressed.1203 !!1204 !!----------------------------------------------------------------------1205 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo1206 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points1207 ! ! = T , U , V , F or W -points1208 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the1209 !! ! north fold, = 1. otherwise1210 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold1211 !1212 INTEGER :: ji, jj, jr1213 INTEGER :: ierr, itaille, ildi, ilei, iilb1214 INTEGER :: ipj, ij, iproc1215 !1216 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e1217 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e1218 !!----------------------------------------------------------------------1219 !1220 ipj=41221 ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &1222 & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &1223 & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )1224 !1225 ztab_e(:,:) = 0._wp1226 znorthloc_e(:,:) = 0._wp1227 !1228 ij = 1 - kextj1229 ! put the last ipj+2*kextj lines of pt2d into znorthloc_e1230 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1231 znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)1232 ij = ij + 11233 END DO1234 !1235 itaille = jpimax * ( ipj + 2*kextj )1236 !1237 IF( ln_timing ) CALL tic_tac(.TRUE.)1238 CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &1239 & znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &1240 & ncomm_north, ierr )1241 !1242 IF( ln_timing ) CALL tic_tac(.FALSE.)1243 !1244 DO jr = 1, ndim_rank_north ! recover the global north array1245 iproc = nrank_north(jr) + 11246 ildi = nldit (iproc)1247 ilei = nleit (iproc)1248 iilb = nimppt(iproc)1249 DO jj = 1-kextj, ipj+kextj1250 DO ji = ildi, ilei1251 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)1252 END DO1253 END DO1254 END DO1255 1256 ! 2. North-Fold boundary conditions1257 ! ----------------------------------1258 CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )1259 1260 ij = 1 - kextj1261 !! Scatter back to pt2d1262 DO jj = jpj - ipj + 1 - kextj , jpj + kextj1263 DO ji= 1, jpi1264 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)1265 END DO1266 ij = ij +11267 END DO1268 !1269 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )1270 !1271 END SUBROUTINE mpp_lbc_north_icb1272 1273 1274 SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )1275 !!----------------------------------------------------------------------1276 !! *** routine mpp_lnk_2d_icb ***1277 !!1278 !! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)1279 !! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)1280 !! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.1281 !!1282 !! ** Method : Use mppsend and mpprecv function for passing mask1283 !! between processors following neighboring subdomains.1284 !! domain parameters1285 !! jpi : first dimension of the local subdomain1286 !! jpj : second dimension of the local subdomain1287 !! kexti : number of columns for extra outer halo1288 !! kextj : number of rows for extra outer halo1289 !! nbondi : mark for "east-west local boundary"1290 !! nbondj : mark for "north-south local boundary"1291 !! noea : number for local neighboring processors1292 !! nowe : number for local neighboring processors1293 !! noso : number for local neighboring processors1294 !! nono : number for local neighboring processors1295 !!----------------------------------------------------------------------1296 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine1297 REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo1298 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points1299 REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold1300 INTEGER , INTENT(in ) :: kexti ! extra i-halo width1301 INTEGER , INTENT(in ) :: kextj ! extra j-halo width1302 !1303 INTEGER :: jl ! dummy loop indices1304 INTEGER :: imigr, iihom, ijhom ! local integers1305 INTEGER :: ipreci, iprecj ! - -1306 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend1307 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend1308 !!1309 REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn1310 REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew1311 !!----------------------------------------------------------------------1312 1313 ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area1314 iprecj = nn_hls + kextj1315 1316 IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )1317 1318 ! 1. standard boundary treatment1319 ! ------------------------------1320 ! Order matters Here !!!!1321 !1322 ! ! East-West boundaries1323 ! !* Cyclic east-west1324 IF( l_Iperio ) THEN1325 pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east1326 pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west1327 !1328 ELSE !* closed1329 IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point1330 pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west1331 ENDIF1332 ! ! North-South boundaries1333 IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)1334 pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north1335 pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south1336 ELSE !* closed1337 IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point1338 pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south1339 ENDIF1340 !1341 1342 ! north fold treatment1343 ! -----------------------1344 IF( npolj /= 0 ) THEN1345 !1346 SELECT CASE ( jpni )1347 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1348 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )1349 END SELECT1350 !1351 ENDIF1352 1353 ! 2. East and west directions exchange1354 ! ------------------------------------1355 ! we play with the neigbours AND the row number because of the periodicity1356 !1357 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions1358 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)1359 iihom = jpi-nreci-kexti1360 DO jl = 1, ipreci1361 r2dew(:,jl,1) = pt2d(nn_hls+jl,:)1362 r2dwe(:,jl,1) = pt2d(iihom +jl,:)1363 END DO1364 END SELECT1365 !1366 ! ! Migrations1367 imigr = ipreci * ( jpj + 2*kextj )1368 !1369 IF( ln_timing ) CALL tic_tac(.TRUE.)1370 !1371 SELECT CASE ( nbondi )1372 CASE ( -1 )1373 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )1374 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1375 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1376 CASE ( 0 )1377 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1378 CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )1379 CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )1380 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1381 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1382 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1383 CASE ( 1 )1384 CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )1385 CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )1386 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1387 END SELECT1388 !1389 IF( ln_timing ) CALL tic_tac(.FALSE.)1390 !1391 ! ! Write Dirichlet lateral conditions1392 iihom = jpi - nn_hls1393 !1394 SELECT CASE ( nbondi )1395 CASE ( -1 )1396 DO jl = 1, ipreci1397 pt2d(iihom+jl,:) = r2dew(:,jl,2)1398 END DO1399 CASE ( 0 )1400 DO jl = 1, ipreci1401 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1402 pt2d(iihom+jl,:) = r2dew(:,jl,2)1403 END DO1404 CASE ( 1 )1405 DO jl = 1, ipreci1406 pt2d(jl-kexti,:) = r2dwe(:,jl,2)1407 END DO1408 END SELECT1409 1410 1411 ! 3. North and south directions1412 ! -----------------------------1413 ! always closed : we play only with the neigbours1414 !1415 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions1416 ijhom = jpj-nrecj-kextj1417 DO jl = 1, iprecj1418 r2dsn(:,jl,1) = pt2d(:,ijhom +jl)1419 r2dns(:,jl,1) = pt2d(:,nn_hls+jl)1420 END DO1421 ENDIF1422 !1423 ! ! Migrations1424 imigr = iprecj * ( jpi + 2*kexti )1425 !1426 IF( ln_timing ) CALL tic_tac(.TRUE.)1427 !1428 SELECT CASE ( nbondj )1429 CASE ( -1 )1430 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )1431 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1432 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1433 CASE ( 0 )1434 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1435 CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )1436 CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )1437 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1438 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1439 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)1440 CASE ( 1 )1441 CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )1442 CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )1443 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)1444 END SELECT1445 !1446 IF( ln_timing ) CALL tic_tac(.FALSE.)1447 !1448 ! ! Write Dirichlet lateral conditions1449 ijhom = jpj - nn_hls1450 !1451 SELECT CASE ( nbondj )1452 CASE ( -1 )1453 DO jl = 1, iprecj1454 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1455 END DO1456 CASE ( 0 )1457 DO jl = 1, iprecj1458 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1459 pt2d(:,ijhom+jl) = r2dns(:,jl,2)1460 END DO1461 CASE ( 1 )1462 DO jl = 1, iprecj1463 pt2d(:,jl-kextj) = r2dsn(:,jl,2)1464 END DO1465 END SELECT1466 !1467 END SUBROUTINE mpp_lnk_2d_icb1468 1469 1470 897 SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 1471 898 !!---------------------------------------------------------------------- … … 1479 906 LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg 1480 907 !! 908 CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications 1481 909 LOGICAL :: ll_lbc, ll_glb, ll_dlg 1482 INTEGER :: ji, jj, jk, jh, jf ! dummy loop indices 1483 !!---------------------------------------------------------------------- 910 INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices 911 !!---------------------------------------------------------------------- 912 #if defined key_mpp_mpi 1484 913 ! 1485 914 ll_lbc = .FALSE. … … 1536 965 WRITE(numcom,*) ' ' 1537 966 WRITE(numcom,*) ' lbc_lnk called' 1538 jj = 1 1539 DO ji = 2, n_sequence_lbc 1540 IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 1541 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 1542 jj = 0 967 DO ji = 1, n_sequence_lbc - 1 968 IF ( crname_lbc(ji) /= 'already counted' ) THEN 969 ccountname = crname_lbc(ji) 970 crname_lbc(ji) = 'already counted' 971 jcount = 1 972 DO jj = ji + 1, n_sequence_lbc 973 IF ( ccountname == crname_lbc(jj) ) THEN 974 jcount = jcount + 1 975 crname_lbc(jj) = 'already counted' 976 END IF 977 END DO 978 WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) 1543 979 END IF 1544 jj = jj + 11545 980 END DO 1546 WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 981 IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 982 WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 983 END IF 1547 984 WRITE(numcom,*) ' ' 1548 985 IF ( n_sequence_glb > 0 ) THEN … … 1583 1020 DEALLOCATE(crname_lbc) 1584 1021 ENDIF 1022 #endif 1585 1023 END SUBROUTINE mpp_report 1586 1024 … … 1593 1031 REAL(wp), SAVE :: tic_ct = 0._wp 1594 1032 INTEGER :: ii 1033 #if defined key_mpp_mpi 1595 1034 1596 1035 IF( ncom_stp <= nit000 ) RETURN … … 1608 1047 tic_ct = MPI_Wtime() ! start count tac->tic (waiting time) 1609 1048 ENDIF 1049 #endif 1610 1050 1611 1051 END SUBROUTINE tic_tac 1612 1052 1053 #if ! defined key_mpp_mpi 1054 SUBROUTINE mpi_wait(request, status, ierror) 1055 INTEGER , INTENT(in ) :: request 1056 INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status 1057 INTEGER , INTENT( out) :: ierror 1058 END SUBROUTINE mpi_wait 1059 1613 1060 1614 #else 1615 !!---------------------------------------------------------------------- 1616 !! Default case: Dummy module share memory computing 1617 !!---------------------------------------------------------------------- 1618 USE in_out_manager 1619 1620 INTERFACE mpp_sum 1621 MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 1622 END INTERFACE 1623 INTERFACE mpp_max 1624 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 1625 END INTERFACE 1626 INTERFACE mpp_min 1627 MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 1628 END INTERFACE 1629 INTERFACE mpp_minloc 1630 MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 1631 END INTERFACE 1632 INTERFACE mpp_maxloc 1633 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 1634 END INTERFACE 1635 1636 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 1637 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 1638 INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator 1639 1640 INTEGER, PARAMETER, PUBLIC :: nbdelay = 0 ! make sure we don't enter loops: DO ji = 1, nbdelay 1641 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaylist = 'empty' 1642 CHARACTER(len=32), DIMENSION(1), PUBLIC :: c_delaycpnt = 'empty' 1643 LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. 1644 TYPE :: DELAYARR 1645 REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL() 1646 COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL() 1647 END TYPE DELAYARR 1648 TYPE( DELAYARR ), DIMENSION(1), PUBLIC :: todelay 1649 INTEGER, PUBLIC, DIMENSION(1) :: ndelayid = -1 1650 !!---------------------------------------------------------------------- 1651 CONTAINS 1652 1653 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 1654 INTEGER, INTENT(in) :: kumout 1655 lib_mpp_alloc = 0 1656 END FUNCTION lib_mpp_alloc 1657 1658 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 1659 INTEGER, OPTIONAL , INTENT(in ) :: localComm 1660 CHARACTER(len=*),DIMENSION(:) :: ldtxt 1661 CHARACTER(len=*) :: ldname 1662 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 1663 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 1664 function_value = 0 1665 IF( .FALSE. ) ldtxt(:) = 'never done' 1666 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 1667 END FUNCTION mynode 1668 1669 SUBROUTINE mppsync ! Dummy routine 1670 END SUBROUTINE mppsync 1671 1672 !!---------------------------------------------------------------------- 1673 !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** 1674 !! 1675 !!---------------------------------------------------------------------- 1676 !! 1677 # define OPERATION_MAX 1678 # define INTEGER_TYPE 1679 # define DIM_0d 1680 # define ROUTINE_ALLREDUCE mppmax_int 1681 # include "mpp_allreduce_generic.h90" 1682 # undef ROUTINE_ALLREDUCE 1683 # undef DIM_0d 1684 # define DIM_1d 1685 # define ROUTINE_ALLREDUCE mppmax_a_int 1686 # include "mpp_allreduce_generic.h90" 1687 # undef ROUTINE_ALLREDUCE 1688 # undef DIM_1d 1689 # undef INTEGER_TYPE 1690 ! 1691 # define REAL_TYPE 1692 # define DIM_0d 1693 # define ROUTINE_ALLREDUCE mppmax_real 1694 # include "mpp_allreduce_generic.h90" 1695 # undef ROUTINE_ALLREDUCE 1696 # undef DIM_0d 1697 # define DIM_1d 1698 # define ROUTINE_ALLREDUCE mppmax_a_real 1699 # include "mpp_allreduce_generic.h90" 1700 # undef ROUTINE_ALLREDUCE 1701 # undef DIM_1d 1702 # undef REAL_TYPE 1703 # undef OPERATION_MAX 1704 !!---------------------------------------------------------------------- 1705 !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** 1706 !! 1707 !!---------------------------------------------------------------------- 1708 !! 1709 # define OPERATION_MIN 1710 # define INTEGER_TYPE 1711 # define DIM_0d 1712 # define ROUTINE_ALLREDUCE mppmin_int 1713 # include "mpp_allreduce_generic.h90" 1714 # undef ROUTINE_ALLREDUCE 1715 # undef DIM_0d 1716 # define DIM_1d 1717 # define ROUTINE_ALLREDUCE mppmin_a_int 1718 # include "mpp_allreduce_generic.h90" 1719 # undef ROUTINE_ALLREDUCE 1720 # undef DIM_1d 1721 # undef INTEGER_TYPE 1722 ! 1723 # define REAL_TYPE 1724 # define DIM_0d 1725 # define ROUTINE_ALLREDUCE mppmin_real 1726 # include "mpp_allreduce_generic.h90" 1727 # undef ROUTINE_ALLREDUCE 1728 # undef DIM_0d 1729 # define DIM_1d 1730 # define ROUTINE_ALLREDUCE mppmin_a_real 1731 # include "mpp_allreduce_generic.h90" 1732 # undef ROUTINE_ALLREDUCE 1733 # undef DIM_1d 1734 # undef REAL_TYPE 1735 # undef OPERATION_MIN 1736 1737 !!---------------------------------------------------------------------- 1738 !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** 1739 !! 1740 !! Global sum of 1D array or a variable (integer, real or complex) 1741 !!---------------------------------------------------------------------- 1742 !! 1743 # define OPERATION_SUM 1744 # define INTEGER_TYPE 1745 # define DIM_0d 1746 # define ROUTINE_ALLREDUCE mppsum_int 1747 # include "mpp_allreduce_generic.h90" 1748 # undef ROUTINE_ALLREDUCE 1749 # undef DIM_0d 1750 # define DIM_1d 1751 # define ROUTINE_ALLREDUCE mppsum_a_int 1752 # include "mpp_allreduce_generic.h90" 1753 # undef ROUTINE_ALLREDUCE 1754 # undef DIM_1d 1755 # undef INTEGER_TYPE 1756 ! 1757 # define REAL_TYPE 1758 # define DIM_0d 1759 # define ROUTINE_ALLREDUCE mppsum_real 1760 # include "mpp_allreduce_generic.h90" 1761 # undef ROUTINE_ALLREDUCE 1762 # undef DIM_0d 1763 # define DIM_1d 1764 # define ROUTINE_ALLREDUCE mppsum_a_real 1765 # include "mpp_allreduce_generic.h90" 1766 # undef ROUTINE_ALLREDUCE 1767 # undef DIM_1d 1768 # undef REAL_TYPE 1769 # undef OPERATION_SUM 1770 1771 # define OPERATION_SUM_DD 1772 # define COMPLEX_TYPE 1773 # define DIM_0d 1774 # define ROUTINE_ALLREDUCE mppsum_realdd 1775 # include "mpp_allreduce_generic.h90" 1776 # undef ROUTINE_ALLREDUCE 1777 # undef DIM_0d 1778 # define DIM_1d 1779 # define ROUTINE_ALLREDUCE mppsum_a_realdd 1780 # include "mpp_allreduce_generic.h90" 1781 # undef ROUTINE_ALLREDUCE 1782 # undef DIM_1d 1783 # undef COMPLEX_TYPE 1784 # undef OPERATION_SUM_DD 1785 1786 !!---------------------------------------------------------------------- 1787 !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 1788 !! 1789 !!---------------------------------------------------------------------- 1790 !! 1791 # define OPERATION_MINLOC 1792 # define DIM_2d 1793 # define ROUTINE_LOC mpp_minloc2d 1794 # include "mpp_loc_generic.h90" 1795 # undef ROUTINE_LOC 1796 # undef DIM_2d 1797 # define DIM_3d 1798 # define ROUTINE_LOC mpp_minloc3d 1799 # include "mpp_loc_generic.h90" 1800 # undef ROUTINE_LOC 1801 # undef DIM_3d 1802 # undef OPERATION_MINLOC 1803 1804 # define OPERATION_MAXLOC 1805 # define DIM_2d 1806 # define ROUTINE_LOC mpp_maxloc2d 1807 # include "mpp_loc_generic.h90" 1808 # undef ROUTINE_LOC 1809 # undef DIM_2d 1810 # define DIM_3d 1811 # define ROUTINE_LOC mpp_maxloc3d 1812 # include "mpp_loc_generic.h90" 1813 # undef ROUTINE_LOC 1814 # undef DIM_3d 1815 # undef OPERATION_MAXLOC 1816 1817 SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 1818 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1819 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1820 COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in 1821 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1822 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1823 INTEGER, INTENT(in ), OPTIONAL :: kcom 1824 ! 1825 pout(:) = REAL(y_in(:), wp) 1826 END SUBROUTINE mpp_delay_sum 1827 1828 SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 1829 CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine 1830 CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation 1831 REAL(wp), INTENT(in ), DIMENSION(:) :: p_in 1832 REAL(wp), INTENT( out), DIMENSION(:) :: pout 1833 LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine 1834 INTEGER, INTENT(in ), OPTIONAL :: kcom 1835 ! 1836 pout(:) = p_in(:) 1837 END SUBROUTINE mpp_delay_max 1838 1839 SUBROUTINE mpp_delay_rcv( kid ) 1840 INTEGER,INTENT(in ) :: kid 1841 WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 1842 END SUBROUTINE mpp_delay_rcv 1843 1844 SUBROUTINE mppstop( ldfinal, ld_force_abort ) 1845 LOGICAL, OPTIONAL, INTENT(in) :: ldfinal ! source process number 1846 LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort ! source process number 1847 STOP ! non MPP case, just stop the run 1848 END SUBROUTINE mppstop 1849 1850 SUBROUTINE mpp_ini_znl( knum ) 1851 INTEGER :: knum 1852 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 1853 END SUBROUTINE mpp_ini_znl 1854 1855 SUBROUTINE mpp_comm_free( kcom ) 1856 INTEGER :: kcom 1857 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 1858 END SUBROUTINE mpp_comm_free 1859 1860 #endif 1861 1862 !!---------------------------------------------------------------------- 1863 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1061 FUNCTION MPI_Wtime() 1062 REAL(wp) :: MPI_Wtime 1063 MPI_Wtime = -1. 1064 END FUNCTION MPI_Wtime 1065 #endif 1066 1067 !!---------------------------------------------------------------------- 1068 !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines 1864 1069 !!---------------------------------------------------------------------- 1865 1070 … … 1872 1077 !! increment the error number (nstop) by one. 1873 1078 !!---------------------------------------------------------------------- 1874 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 1875 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1079 CHARACTER(len=*), INTENT(in ) :: cd1 1080 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5 1081 CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 1876 1082 !!---------------------------------------------------------------------- 1877 1083 ! 1878 1084 nstop = nstop + 1 1879 1880 ! force to open ocean.output file 1085 ! 1086 ! force to open ocean.output file if not already opened 1881 1087 IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 1882 1883 WRITE(numout,cform_err) 1884 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1088 ! 1089 WRITE(numout,*) 1090 WRITE(numout,*) ' ===>>> : E R R O R' 1091 WRITE(numout,*) 1092 WRITE(numout,*) ' ===========' 1093 WRITE(numout,*) 1094 WRITE(numout,*) TRIM(cd1) 1885 1095 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1886 1096 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1892 1102 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1893 1103 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1894 1104 WRITE(numout,*) 1105 ! 1895 1106 CALL FLUSH(numout ) 1896 1107 IF( numstp /= -1 ) CALL FLUSH(numstp ) … … 1899 1110 ! 1900 1111 IF( cd1 == 'STOP' ) THEN 1112 WRITE(numout,*) 1901 1113 WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 1902 CALL mppstop(ld_force_abort = .true.) 1114 WRITE(numout,*) 1115 CALL mppstop( ld_abort = .true. ) 1903 1116 ENDIF 1904 1117 ! … … 1919 1132 ! 1920 1133 nwarn = nwarn + 1 1134 ! 1921 1135 IF(lwp) THEN 1922 WRITE(numout,cform_war) 1923 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1924 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1925 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1926 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1927 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1928 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1929 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1930 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1931 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1932 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1136 WRITE(numout,*) 1137 WRITE(numout,*) ' ===>>> : W A R N I N G' 1138 WRITE(numout,*) 1139 WRITE(numout,*) ' ===============' 1140 WRITE(numout,*) 1141 IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 1142 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1143 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 1144 IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 1145 IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 1146 IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 1147 IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 1148 IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 1149 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1150 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1151 WRITE(numout,*) 1933 1152 ENDIF 1934 1153 CALL FLUSH(numout) … … 1973 1192 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1974 1193 ! 1975 iost=0 1976 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1194 IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters 1977 1195 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1978 1196 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 1995 1213 100 CONTINUE 1996 1214 IF( iost /= 0 ) THEN 1997 IF(ldwp) THEN 1998 WRITE(kout,*) 1999 WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2000 WRITE(kout,*) ' ======= === ' 2001 WRITE(kout,*) ' unit = ', knum 2002 WRITE(kout,*) ' status = ', cdstat 2003 WRITE(kout,*) ' form = ', cdform 2004 WRITE(kout,*) ' access = ', cdacce 2005 WRITE(kout,*) ' iostat = ', iost 2006 WRITE(kout,*) ' we stop. verify the file ' 2007 WRITE(kout,*) 2008 ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 2009 WRITE(*,*) 2010 WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 2011 WRITE(*,*) ' ======= === ' 2012 WRITE(*,*) ' unit = ', knum 2013 WRITE(*,*) ' status = ', cdstat 2014 WRITE(*,*) ' form = ', cdform 2015 WRITE(*,*) ' access = ', cdacce 2016 WRITE(*,*) ' iostat = ', iost 2017 WRITE(*,*) ' we stop. verify the file ' 2018 WRITE(*,*) 2019 ENDIF 2020 CALL FLUSH( kout ) 2021 STOP 'ctl_opn bad opening' 1215 WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 1216 WRITE(ctmp2,*) ' ======= === ' 1217 WRITE(ctmp3,*) ' unit = ', knum 1218 WRITE(ctmp4,*) ' status = ', cdstat 1219 WRITE(ctmp5,*) ' form = ', cdform 1220 WRITE(ctmp6,*) ' access = ', cdacce 1221 WRITE(ctmp7,*) ' iostat = ', iost 1222 WRITE(ctmp8,*) ' we stop. verify the file ' 1223 CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 2022 1224 ENDIF 2023 1225 ! … … 2025 1227 2026 1228 2027 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1229 SUBROUTINE ctl_nam ( kios, cdnam ) 2028 1230 !!---------------------------------------------------------------------- 2029 1231 !! *** ROUTINE ctl_nam *** … … 2033 1235 !! ** Method : Fortan open 2034 1236 !!---------------------------------------------------------------------- 2035 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist2036 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs2037 CHARACTER(len=5) :: clios ! string to convert iostat in character for print2038 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1237 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 1238 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 1239 ! 1240 CHARACTER(len=5) :: clios ! string to convert iostat in character for print 2039 1241 !!---------------------------------------------------------------------- 2040 1242 ! … … 2050 1252 ENDIF 2051 1253 kios = 0 2052 RETURN2053 1254 ! 2054 1255 END SUBROUTINE ctl_nam … … 2071 1272 END DO 2072 1273 IF( (get_unit == 999) .AND. llopn ) THEN 2073 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 2074 get_unit = -1 1274 CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 2075 1275 ENDIF 2076 1276 !
Note: See TracChangeset
for help on using the changeset viewer.
