Changeset 1324
- Timestamp:
- 2009-02-20T11:00:03+01:00 (15 years ago)
- Location:
- trunk/NEMO/OFF_SRC
- Files:
-
- 6 edited
-
IOM/in_out_manager.F90 (modified) (8 diffs)
-
IOM/iom.F90 (modified) (12 diffs)
-
IOM/iom_def.F90 (modified) (1 diff)
-
IOM/iom_ioipsl.F90 (modified) (1 diff)
-
IOM/iom_nf90.F90 (modified) (1 diff)
-
lib_mpp.F90 (modified) (73 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OFF_SRC/IOM/in_out_manager.F90
r1312 r1324 5 5 !! turbulent closure parameterization 6 6 !!===================================================================== 7 !! History : 8.5 ! 02-06 (G. Madec) original code 8 !! 9.0 ! 06-07 (S. Masson) iom, add ctl_stop, ctl_warn 7 !! History : 1.0 ! 2002-06 (G. Madec) original code 8 !! 2.0 ! 2006-07 (S. Masson) iom, add ctl_stop, ctl_warn 9 !! 3.0 ! 2008-06 (G. Madec) add ctmp4 to ctmp10 9 10 !!---------------------------------------------------------------------- 10 11 … … 12 13 !! ctl_stop : update momentum and tracer Kz from a tke scheme 13 14 !! ctl_warn : initialization, namelist read, and parameters control 15 !! getunit : give the index of an unused logical unit 14 16 !!---------------------------------------------------------------------- 15 USE par_kind 16 USE par_oce 17 USE lib_print 17 USE par_kind ! kind definition 18 USE par_oce ! ocean parameter 19 USE lib_print ! formated print library 18 20 19 21 IMPLICIT NONE … … 23 25 !! namrun namelist parameters 24 26 !!---------------------------------------------------------------------- 25 CHARACTER (len=16) :: cexper = "exp0" !: experiment name used for output filename 26 LOGICAL :: ln_rstart = .FALSE. !: start from (F) rest or (T) a restart file 27 INTEGER :: no = 0 !: job number 28 INTEGER :: nrstdt = 0 !: control of the time step (0, 1 or 2) 29 INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) 30 INTEGER :: nit000 = 1 !: index of the first time step 31 INTEGER :: nitend = 10 !: index of the last time step 32 INTEGER :: ndate0 = 961115 !: initial calendar date aammjj 33 INTEGER :: nleapy = 0 !: Leap year calendar flag (0/1 or 30) 34 INTEGER :: ninist = 0 !: initial state output flag (0/1) 35 LOGICAL :: ln_dimgnnn = .FALSE. !: type of dimgout. (F): 1 file for all proc 36 !: (T): 1 file per proc 37 LOGICAL :: ln_mskland = .FALSE. !: mask land points in NetCDF outputs (costly: + ~15%) 27 CHARACTER(len=16) :: cexper = "exp0" !: experiment name used for output filename 28 CHARACTER(len=32) :: cn_ocerst_in = "restart" !: suffix of ocean restart name (input) 29 CHARACTER(len=32) :: cn_ocerst_out = "restart" !: suffix of ocean restart name (output) 30 LOGICAL :: ln_rstart = .FALSE. !: start from (F) rest or (T) a restart file 31 INTEGER :: no = 0 !: job number 32 INTEGER :: nrstdt = 0 !: control of the time step (0, 1 or 2) 33 INTEGER :: nn_rstssh = 0 !: hand made initilization of ssh or not (1/0) 34 INTEGER :: nit000 = 1 !: index of the first time step 35 INTEGER :: nitend = 10 !: index of the last time step 36 INTEGER :: ndate0 = 961115 !: initial calendar date aammjj 37 INTEGER :: nleapy = 0 !: Leap year calendar flag (0/1 or 30) 38 INTEGER :: ninist = 0 !: initial state output flag (0/1) 39 LOGICAL :: ln_dimgnnn = .FALSE. !: type of dimgout. (F): 1 file for all proc 40 !: (T): 1 file per proc 41 LOGICAL :: ln_mskland = .FALSE. !: mask land points in NetCDF outputs (costly: + ~15%) 38 42 !!---------------------------------------------------------------------- 39 43 !! was in restart but moved here because of the OFF line... better solution should be found... 40 44 !!---------------------------------------------------------------------- 41 45 INTEGER :: nitrst !: time step at which restart file should be written 46 #if defined key_zdftke2 47 INTEGER :: nitrst_tke2 !: time step at which restart file should be written 48 #endif 42 49 !!---------------------------------------------------------------------- 43 50 !! output monitoring … … 78 85 INTEGER :: nstop = 0 !: error flag (=number of reason for a premature stop run) 79 86 INTEGER :: nwarn = 0 !: warning flag (=number of warning found during the run) 80 CHARACTER(len=200) :: ctmp1, ctmp2, ctmp3 !: temporary character 87 CHARACTER(len=200) :: ctmp1, ctmp2, ctmp3 !: temporary characters 1 to 3 88 CHARACTER(len=200) :: ctmp4, ctmp5, ctmp6 !: temporary characters 4 to 6 89 CHARACTER(len=200) :: ctmp7, ctmp8, ctmp9 !: temporary characters 7 to 9 90 CHARACTER(len=200) :: ctmp10 !: temporary character 10 81 91 CHARACTER (len=64) :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !: 82 92 CHARACTER (len=64) :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: … … 84 94 LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area 85 95 !!---------------------------------------------------------------------- 86 !! OPA 9.0 , LOCEAN-IPSL (2005)87 !! $Id$ 96 !! NEMO/OPA 3.0 , LOCEAN-IPSL (2008) 97 !! $Id$ 88 98 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 89 99 !!---------------------------------------------------------------------- … … 93 103 SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5, & 94 104 & cd6, cd7, cd8, cd9, cd10 ) 95 !!---------------------------------------------------------------------- -105 !!---------------------------------------------------------------------- 96 106 !! *** ROUTINE stop_opa *** 97 107 !! 98 !! ** Purpose : ??? blah blah.... 99 !!----------------------------------------------------------------------- 108 !! ** Purpose : print in ocean.outpput file a error message and 109 !! increment the error number (nstop) by one. 110 !!---------------------------------------------------------------------- 100 111 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 101 112 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 102 !!---------------------------------------------------------------------- -113 !!---------------------------------------------------------------------- 103 114 ! 104 115 nstop = nstop + 1 … … 123 134 SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, & 124 135 & cd6, cd7, cd8, cd9, cd10 ) 125 !!---------------------------------------------------------------------- -136 !!---------------------------------------------------------------------- 126 137 !! *** ROUTINE stop_warn *** 127 138 !! 128 !! ** Purpose : ??? blah blah.... 129 !!----------------------------------------------------------------------- 139 !! ** Purpose : print in ocean.outpput file a error message and 140 !! increment the warning number (nwarn) by one. 141 !!---------------------------------------------------------------------- 130 142 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 131 143 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 132 !!---------------------------------------------------------------------- -144 !!---------------------------------------------------------------------- 133 145 ! 134 146 nwarn = nwarn + 1 … … 152 164 153 165 FUNCTION getunit() 154 !!-----------------------------------------------------------------------155 !! *** FUNCTION getunit ***156 !!157 !! ** Purpose : ??? blah blah....158 !!-----------------------------------------------------------------------159 INTEGER :: getunit160 LOGICAL :: llopn161 !---------------------------------------------------------------------162 getunit = 15 ! choose a unit that is big enough then it is163 ! not already used in OPA164 llopn = .TRUE.165 DO WHILE( (getunit < 998) .AND. llopn )166 getunit = getunit + 1167 INQUIRE( unit = getunit, opened = llopn )168 END DO169 IF( (getunit == 999) .AND. llopn ) THEN170 CALL ctl_stop( 'getunit: All logical units until 999 are used...' )171 getunit = -1172 ENDIF173 166 !!---------------------------------------------------------------------- 167 !! *** FUNCTION getunit *** 168 !! 169 !! ** Purpose : return the index of an unused logical unit 170 !!---------------------------------------------------------------------- 171 INTEGER :: getunit 172 LOGICAL :: llopn 173 !!---------------------------------------------------------------------- 174 ! 175 getunit = 15 ! choose a unit that is big enough then it is not already used in NEMO 176 llopn = .TRUE. 177 DO WHILE( (getunit < 998) .AND. llopn ) 178 getunit = getunit + 1 179 INQUIRE( unit = getunit, opened = llopn ) 180 END DO 181 IF( (getunit == 999) .AND. llopn ) THEN 182 CALL ctl_stop( 'getunit: All logical units until 999 are used...' ) 183 getunit = -1 184 ENDIF 185 ! 174 186 END FUNCTION getunit 175 187 -
trunk/NEMO/OFF_SRC/IOM/iom.F90
r1152 r1324 69 69 LOGICAL :: llok ! check the existence 70 70 LOGICAL :: llwrt ! local definition of ldwrt 71 LOGICAL :: llnoov ! local definition to read overlap 71 72 LOGICAL :: llstop ! local definition of ldstop 72 73 INTEGER :: iolib ! library do we use to open the file … … 104 105 ELSE ; iolib = jpnf90 105 106 ENDIF 107 ! do we read the overlap 108 ! ugly patch SM+JMM+RB to overwrite global definition in some cases 109 #if ! defined key_agrif 110 llnoov = (jpni * jpnj ) == jpnij 111 #endif 106 112 ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) 107 113 ! ============= 108 114 clname = trim(cdname) 109 115 #if defined key_agrif 110 if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname) 116 IF ( .NOT. Agrif_Root() ) THEN 117 iln = INDEX(clname,'/') 118 cltmpn = clname(1:iln) 119 clname = clname(iln+1:LEN_TRIM(clname)) 120 clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) 121 ENDIF 111 122 #endif 112 123 ! which suffix should we use? … … 149 160 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 150 161 ! idom = jpdom_local_noovlap ! default definition 151 IF( jpni*jpnj == jpnij) THEN ; idom = jpdom_local_noovlap ! default definition152 ELSE 162 IF( llnoov ) THEN ; idom = jpdom_local_noovlap ! default definition 163 ELSE ; idom = jpdom_local_full ! default definition 153 164 ENDIF 154 165 IF( PRESENT(kdom) ) idom = kdom … … 212 223 !! ** Purpose : close an input file, or all files opened by iom 213 224 !!-------------------------------------------------------------------- 214 INTEGER, INTENT(in), OPTIONAL :: kiomid ! iom identifier of the file to be closed 215 ! ! No argument : all the files opened by iom are closed 225 INTEGER, INTENT(inout), OPTIONAL :: kiomid ! iom identifier of the file to be closed 226 ! ! return 0 when file is properly closed 227 ! ! No argument: all files opened by iom are closed 216 228 217 229 INTEGER :: jf ! dummy loop indices … … 239 251 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 240 252 END SELECT 241 iom_file(jf)%nfid = 0 ! free the id 253 iom_file(jf)%nfid = 0 ! free the id 254 IF( PRESENT(kiomid) ) kiomid = 0 ! return 0 as id to specify that the file was closed 242 255 IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok' 243 256 ELSEIF( PRESENT(kiomid) ) THEN … … 409 422 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 410 423 ! 424 LOGICAL :: llnoov ! local definition to read overlap 411 425 INTEGER :: jl ! loop on number of dimension 412 426 INTEGER :: idom ! type of domain … … 435 449 ! local definition of the domain ? 436 450 idom = kdom 451 ! do we read the overlap 452 ! ugly patch SM+JMM+RB to overwrite global definition in some cases 453 #if ! defined key_agrif 454 llnoov = (jpni * jpnj ) == jpnij 455 #endif 437 456 ! check kcount and kstart optionals parameters... 438 457 IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') … … 518 537 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 519 538 ! IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 520 IF( jpni*jpnj == jpnij.AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /)539 IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 521 540 ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej 522 541 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 523 542 ! icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 524 IF( jpni*jpnj == jpnij) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /)525 ELSE 543 IF( llnoov ) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 544 ELSE ; icnt(1:2) = (/ nlci , nlcj /) 526 545 ENDIF 527 546 IF( PRESENT(pv_r3d) ) THEN … … 556 575 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 557 576 ! ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1 = 'd(nldi:nlei,nldj:nlej)' 558 IF( jpni*jpnj == jpnij) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)'559 ELSE 577 IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)' 578 ELSE ; ishape(1:2)=SHAPE(pv_r2d(1 :nlci,1 :nlcj )) ; ctmp1='d(1:nlci,1:nlcj)' 560 579 ENDIF 561 580 ENDIF … … 563 582 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 564 583 ! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 565 IF( jpni*jpnj == jpnij) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)'566 ELSE 584 IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 585 ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 567 586 ENDIF 568 587 ENDIF … … 585 604 ! ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) 586 605 ! ENDIF 587 IF( jpni*jpnj == jpnij) THEN606 IF( llnoov ) THEN 588 607 IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej 589 608 ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) … … 607 626 608 627 IF( istop == nstop ) THEN ! no additional errors until this point... 609 IF(lwp) WRITE(numout, *) ' read '//TRIM(cdvar)//' in '//TRIM(iom_file(kiomid)%name)//' ok'610 628 IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i4,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 629 611 630 !--- overlap areas and extra hallows (mpp) 612 631 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN -
trunk/NEMO/OFF_SRC/IOM/iom_def.F90
r1152 r1324 43 43 INTEGER, PARAMETER, PUBLIC :: jp_i1 = 204 !: write INTEGER(1) 44 44 45 INTEGER, PARAMETER, PUBLIC :: jpmax_files = 20 !: maximum number of simultaneously opened file45 INTEGER, PARAMETER, PUBLIC :: jpmax_files = 50 !: maximum number of simultaneously opened file 46 46 INTEGER, PARAMETER, PUBLIC :: jpmax_vars = 360 !: maximum number of variables in one file 47 47 INTEGER, PARAMETER, PUBLIC :: jpmax_dims = 4 !: maximum number of dimensions for one variable -
trunk/NEMO/OFF_SRC/IOM/iom_ioipsl.F90
r1152 r1324 287 287 !! ** Purpose : read the time axis cdvar in the file 288 288 !!-------------------------------------------------------------------- 289 INTEGER 290 INTEGER 291 INTEGER 292 CHARACTER(len=*) 293 INTEGER 294 INTEGER 295 REAL(wp) 296 REAL(wp), DIMENSION( jpk), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field297 REAL(wp), DIMENSION( jpi,jpj), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field298 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field289 INTEGER , INTENT(in) :: kt ! ocean time-step 290 INTEGER , INTENT(in) :: kwrite ! writing time-step 291 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 292 CHARACTER(len=*) , INTENT(in) :: cdvar ! variable name 293 INTEGER , INTENT(in) :: kvid ! variable id 294 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) 295 REAL(wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field 296 REAL(wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 297 REAL(wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field 298 REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field 299 299 ! 300 300 INTEGER :: idims ! number of dimension -
trunk/NEMO/OFF_SRC/IOM/iom_nf90.F90
r1152 r1324 313 313 !! ** Purpose : read the time axis cdvar in the file 314 314 !!-------------------------------------------------------------------- 315 INTEGER 316 INTEGER 317 INTEGER 318 CHARACTER(len=*) 319 INTEGER 320 INTEGER 321 REAL(wp) 322 REAL(wp), DIMENSION( jpk), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field323 REAL(wp), DIMENSION( jpi,jpj), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field324 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field315 INTEGER , INTENT(in) :: kt ! ocean time-step 316 INTEGER , INTENT(in) :: kwrite ! writing time-step 317 INTEGER , INTENT(in) :: kiomid ! Identifier of the file 318 CHARACTER(len=*) , INTENT(in) :: cdvar ! variable name 319 INTEGER , INTENT(in) :: kvid ! variable id 320 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable type (default R8) 321 REAL(wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field 322 REAL(wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field 323 REAL(wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field 324 REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL :: pv_r3d ! written 3d field 325 325 ! 326 326 INTEGER :: idims ! number of dimension -
trunk/NEMO/OFF_SRC/lib_mpp.F90
r1152 r1324 26 26 !! mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real 27 27 !! mpp_max : generic interface for : 28 !! mppmax_ real, mppmax_a_real28 !! mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real 29 29 !! mpp_sum : generic interface for : 30 30 !! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real … … 45 45 !! ! 04 (R. Bourdalle Badie) isend option in mpi 46 46 !! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases 47 !! ! 05 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort 47 48 !!---------------------------------------------------------------------- 48 49 !! OPA 9.0 , LOCEAN-IPSL (2005) 49 !! $Id$ 50 !! $Id$ 50 51 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 51 52 !!--------------------------------------------------------------------- … … 59 60 PUBLIC mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum, mpp_lbc_north 60 61 PUBLIC mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks 61 PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 62 PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free 63 #if defined key_oasis3 || defined key_oasis4 64 PUBLIC mppsize, mpprank 65 #endif 62 66 63 67 !! * Interfaces … … 73 77 END INTERFACE 74 78 INTERFACE mpp_max 75 MODULE PROCEDURE mppmax_a_ real, mppmax_real79 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 76 80 END INTERFACE 77 81 INTERFACE mpp_sum … … 94 98 !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 95 99 INTEGER, PARAMETER :: & 96 nprocmax = 2**10, & ! maximun dimension 97 ndim_mpp = jpnij ! dimension for this simulation 100 nprocmax = 2**10 ! maximun dimension 98 101 99 102 #if defined key_mpp_mpi … … 106 109 107 110 INTEGER :: & 108 size, & ! number of process 109 rank ! process number [ 0 - size-1 ] 110 111 mppsize, & ! number of process 112 mpprank, & ! process number [ 0 - size-1 ] 113 mpi_comm_opa ! opa local communicator 114 115 ! variables used in case of sea-ice 116 INTEGER, PUBLIC :: & ! 117 ngrp_ice, & ! group ID for the ice processors (to compute rheology) 118 ncomm_ice, & ! communicator made by the processors with sea-ice 119 ndim_rank_ice, & ! number of 'ice' processors 120 n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm 121 INTEGER, DIMENSION(:), ALLOCATABLE :: & 122 nrank_ice ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 111 123 ! variables used in case of north fold condition in mpp_mpi with jpni > 1 112 124 INTEGER :: & ! … … 117 129 njmppmax ! value of njmpp for the processors of the northern line 118 130 INTEGER :: & ! 119 north_root ! number (in the comm_ world) of proc 0 in the northern comm131 north_root ! number (in the comm_opa) of proc 0 in the northern comm 120 132 INTEGER, DIMENSION(:), ALLOCATABLE :: & 121 133 nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north … … 124 136 LOGICAL :: & 125 137 l_isend = .FALSE. ! isend use indicator (T if c_mpi_send='I') 126 138 INTEGER :: & ! size of the buffer in case of mpi_bsend 139 nn_buffer = 0 140 REAL(kind=wp), ALLOCATABLE, DIMENSION(:) :: tampon ! buffer in case of bsend 127 141 128 142 #elif defined key_mpp_shmem … … 266 280 !!---------------------------------------------------------------------- 267 281 !! OPA 9.0 , LOCEAN-IPSL (2005) 268 !! $Id$ 282 !! $Id$ 269 283 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 270 284 !!--------------------------------------------------------------------- … … 272 286 CONTAINS 273 287 274 FUNCTION mynode( )288 FUNCTION mynode(localComm) 275 289 !!---------------------------------------------------------------------- 276 290 !! *** routine mynode *** … … 281 295 #if defined key_mpp_mpi 282 296 !! * Local variables (MPI version) 283 INTEGER :: mynode, ierr 284 NAMELIST/nammpp/ c_mpi_send 297 INTEGER :: mynode, ierr, code 298 LOGICAL :: mpi_was_called 299 INTEGER,OPTIONAL :: localComm 300 NAMELIST/nammpp/ c_mpi_send, nn_buffer 285 301 !!---------------------------------------------------------------------- 286 302 … … 300 316 IF( Agrif_Root() ) THEN 301 317 #endif 318 !!bug RB : should be clean to use Agrif in coupled mode 319 #if ! defined key_agrif 320 CALL mpi_initialized ( mpi_was_called, code ) 321 IF( code /= MPI_SUCCESS ) THEN 322 CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 323 CALL mpi_abort( mpi_comm_world, code, ierr ) 324 ENDIF 325 326 IF( PRESENT(localComm) .and. mpi_was_called ) THEN 327 mpi_comm_opa = localComm 328 SELECT CASE ( c_mpi_send ) 329 CASE ( 'S' ) ! Standard mpi send (blocking) 330 WRITE(numout,*) ' Standard blocking mpi send (send)' 331 CASE ( 'B' ) ! Buffer mpi send (blocking) 332 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 333 CALL mpi_init_opa( ierr ) 334 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 335 WRITE(numout,*) ' Immediate non-blocking send (isend)' 336 l_isend = .TRUE. 337 CASE DEFAULT 338 WRITE(numout,cform_err) 339 WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send 340 nstop = nstop + 1 341 END SELECT 342 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 343 WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator ' 344 WRITE(numout,*) ' without calling MPI_Init before ! ' 345 ELSE 346 #endif 347 SELECT CASE ( c_mpi_send ) 348 CASE ( 'S' ) ! Standard mpi send (blocking) 349 WRITE(numout,*) ' Standard blocking mpi send (send)' 350 CALL mpi_init( ierr ) 351 CASE ( 'B' ) ! Buffer mpi send (blocking) 352 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 353 CALL mpi_init_opa( ierr ) 354 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 355 WRITE(numout,*) ' Immediate non-blocking send (isend)' 356 l_isend = .TRUE. 357 CALL mpi_init( ierr ) 358 CASE DEFAULT 359 WRITE(ctmp1,*) ' bad value for c_mpi_send = ', c_mpi_send 360 CALL ctl_stop( ctmp1 ) 361 END SELECT 362 363 #if ! defined key_agrif 364 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 365 IF( code /= MPI_SUCCESS ) THEN 366 CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 367 CALL mpi_abort( mpi_comm_world, code, ierr ) 368 ENDIF 369 ! 370 ENDIF 371 #endif 372 #if defined key_agrif 373 ELSE 302 374 SELECT CASE ( c_mpi_send ) 303 375 CASE ( 'S' ) ! Standard mpi send (blocking) 304 376 WRITE(numout,*) ' Standard blocking mpi send (send)' 305 CALL mpi_init( ierr )306 377 CASE ( 'B' ) ! Buffer mpi send (blocking) 307 378 WRITE(numout,*) ' Buffer blocking mpi send (bsend)' 308 CALL mpi_init_opa( ierr )309 379 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 310 380 WRITE(numout,*) ' Immediate non-blocking send (isend)' 311 381 l_isend = .TRUE. 312 CALL mpi_init( ierr )313 382 CASE DEFAULT 314 WRITE(ctmp1,*) ' bad value for c_mpi_send = ', c_mpi_send 315 CALL ctl_stop( ctmp1 ) 383 WRITE(numout,cform_err) 384 WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send 385 nstop = nstop + 1 316 386 END SELECT 317 318 #if defined key_agrif319 387 ENDIF 320 #endif 321 322 CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) 323 CALL mpi_comm_size( mpi_comm_world, size, ierr ) 324 mynode = rank 388 389 mpi_comm_opa = mpi_comm_world 390 #endif 391 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 392 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 393 mynode = mpprank 325 394 #else 326 395 !! * Local variables (SHMEM version) … … 356 425 npvm_tids(0) = npvm_mytid 357 426 npvm_me = 0 358 IF( ndim_mpp> nprocmax ) THEN427 IF( jpnij > nprocmax ) THEN 359 428 WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great' 360 429 CALL ctl_stop( ctmp1 ) 361 430 362 431 ELSE 363 npvm_nproc = ndim_mpp432 npvm_nproc = jpnij 364 433 ENDIF 365 434 … … 476 545 ENDIF 477 546 ! --- END receive dimension --- 478 IF( ndim_mpp> nprocmax ) THEN547 IF( jpnij > nprocmax ) THEN 479 548 WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great' 480 549 CALL ctl_stop( ctmp1 ) 481 550 ELSE 482 nt3d_nproc = ndim_mpp551 nt3d_nproc = jpnij 483 552 ENDIF 484 553 IF( mpparent_print /= 0 ) THEN … … 538 607 #endif 539 608 540 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp )609 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 541 610 !!---------------------------------------------------------------------- 542 611 !! *** routine mpp_lnk_3d *** … … 573 642 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 574 643 cd_mpp ! fill the overlap area only 644 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries) 575 645 576 646 !! * Local variables 577 INTEGER :: ji, j k, jl! dummy loop indices647 INTEGER :: ji, jj, jk, jl ! dummy loop indices 578 648 INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers 579 649 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 580 650 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 651 REAL(wp) :: zland 581 652 !!---------------------------------------------------------------------- 582 653 … … 584 655 ! ------------------------------ 585 656 657 IF( PRESENT( pval ) ) THEN ! set land value (zero by default) 658 zland = pval 659 ELSE 660 zland = 0.e0 661 ENDIF 662 586 663 IF( PRESENT( cd_mpp ) ) THEN 587 ! only fill extra allows with 1. 588 ptab( 1:nlci, nlcj+1:jpj, :) = 1.e0 589 ptab(nlci+1:jpi , : , :) = 1.e0 664 DO jj = nlcj+1, jpj ! only fill extra allows last line 665 ptab(1:nlci, jj, :) = ptab(1:nlci, nlej, :) 666 END DO 667 DO ji = nlci+1, jpi ! only fill extra allows last column 668 ptab(ji , : , :) = ptab(nlei , : , :) 669 END DO 590 670 ELSE 591 671 … … 600 680 SELECT CASE ( cd_type ) 601 681 CASE ( 'T', 'U', 'V', 'W' ) 602 ptab( 1 :jpreci,:,:) = 0.e0603 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0682 ptab( 1 :jpreci,:,:) = zland 683 ptab(nlci-jpreci+1:jpi ,:,:) = zland 604 684 CASE ( 'F' ) 605 ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0685 ptab(nlci-jpreci+1:jpi ,:,:) = zland 606 686 END SELECT 607 687 ENDIF … … 611 691 SELECT CASE ( cd_type ) 612 692 CASE ( 'T', 'U', 'V', 'W' ) 613 ptab(:, 1 :jprecj,:) = 0.e0614 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0693 ptab(:, 1 :jprecj,:) = zland 694 ptab(:,nlcj-jprecj+1:jpj ,:) = zland 615 695 CASE ( 'F' ) 616 ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0696 ptab(:,nlcj-jprecj+1:jpj ,:) = zland 617 697 END SELECT 618 698 … … 791 871 792 872 CASE ( 1 ) ! only one proc along I, no mpp exchange 793 873 794 874 SELECT CASE ( npolj ) 795 875 … … 810 890 END DO 811 891 END DO 812 892 813 893 CASE ( 'U' ) 814 894 DO jk = 1, jpk … … 988 1068 989 1069 990 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp )1070 SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 991 1071 !!---------------------------------------------------------------------- 992 1072 !! *** routine mpp_lnk_2d *** … … 1022 1102 CHARACTER(len=3), INTENT( in ), OPTIONAL :: & 1023 1103 cd_mpp ! fill the overlap area only 1104 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries) 1024 1105 1025 1106 !! * Local variables … … 1030 1111 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1031 1112 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1113 REAL(wp) :: zland 1032 1114 !!---------------------------------------------------------------------- 1115 1116 IF( PRESENT( pval ) ) THEN ! set land value (zero by default) 1117 zland = pval 1118 ELSE 1119 zland = 0.e0 1120 ENDIF 1033 1121 1034 1122 ! 1. standard boundary treatment 1035 1123 ! ------------------------------ 1036 1124 IF (PRESENT(cd_mpp)) THEN 1037 ! only fill extra allows with 1. 1038 pt2d( 1:nlci, nlcj+1:jpj) = 1.e0 1039 pt2d(nlci+1:jpi , : ) = 1.e0 1040 1125 DO jj = nlcj+1, jpj ! only fill extra allows last line 1126 pt2d(1:nlci, jj) = pt2d(1:nlci, nlej) 1127 END DO 1128 DO ji = nlci+1, jpi ! only fill extra allows last column 1129 pt2d(ji , : ) = pt2d(nlei , : ) 1130 END DO 1041 1131 ELSE 1042 1132 … … 1051 1141 SELECT CASE ( cd_type ) 1052 1142 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1053 pt2d( 1 :jpreci,:) = 0.e01054 pt2d(nlci-jpreci+1:jpi ,:) = 0.e01143 pt2d( 1 :jpreci,:) = zland 1144 pt2d(nlci-jpreci+1:jpi ,:) = zland 1055 1145 CASE ( 'F' ) 1056 pt2d(nlci-jpreci+1:jpi ,:) = 0.e01146 pt2d(nlci-jpreci+1:jpi ,:) = zland 1057 1147 END SELECT 1058 1148 ENDIF … … 1062 1152 SELECT CASE ( cd_type ) 1063 1153 CASE ( 'T', 'U', 'V', 'W' , 'I' ) 1064 pt2d(:, 1 :jprecj) = 0.e01065 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e01154 pt2d(:, 1 :jprecj) = zland 1155 pt2d(:,nlcj-jprecj+1:jpj ) = zland 1066 1156 CASE ( 'F' ) 1067 pt2d(:,nlcj-jprecj+1:jpj ) = 0.e01157 pt2d(:,nlcj-jprecj+1:jpj ) = zland 1068 1158 END SELECT 1069 1159 … … 1330 1420 1331 1421 CASE ( 'I' ) ! ice U-V point 1332 pt2d( 2 ,nlcj) = 0.e01422 pt2d( 2 ,nlcj) = zland 1333 1423 DO ji = 2 , nlci-1 1334 1424 ijt = iloc - ji + 2 … … 2780 2870 CASE ( 'S' ) ! Standard mpi send (blocking) 2781 2871 CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp, & 2782 & mpi_comm_ world, iflag )2872 & mpi_comm_opa, iflag ) 2783 2873 CASE ( 'B' ) ! Buffer mpi send (blocking) 2784 2874 CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp, & 2785 & mpi_comm_ world, iflag )2875 & mpi_comm_opa, iflag ) 2786 2876 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 2787 2877 ! Be carefull, one more argument here : the mpi request identifier.. 2788 2878 CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp, & 2789 & mpi_comm_ world, md_req, iflag )2879 & mpi_comm_opa, md_req, iflag ) 2790 2880 END SELECT 2791 2881 #endif … … 2815 2905 2816 2906 CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, & 2817 & mpi_comm_ world, istatus, iflag )2907 & mpi_comm_opa, istatus, iflag ) 2818 2908 #endif 2819 2909 … … 2849 2939 itaille=jpi*jpj 2850 2940 CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille, & 2851 & mpi_double_precision, kp , mpi_comm_ world, ierror )2941 & mpi_double_precision, kp , mpi_comm_opa, ierror ) 2852 2942 #endif 2853 2943 … … 2883 2973 2884 2974 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille, & 2885 & mpi_double_precision, kp, mpi_comm_ world, ierror )2975 & mpi_double_precision, kp, mpi_comm_opa, ierror ) 2886 2976 #endif 2887 2977 … … 2944 3034 CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 2945 3035 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer & 2946 , mpi_isl, mpi_comm_ world, ierror )3036 , mpi_isl, mpi_comm_opa, ierror ) 2947 3037 ktab(:) = iwork(:) 2948 3038 #endif … … 2998 3088 CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 2999 3089 CALL mpi_allreduce(ktab, iwork, 1,mpi_integer & 3000 ,mpi_isl,mpi_comm_ world,ierror)3090 ,mpi_isl,mpi_comm_opa,ierror) 3001 3091 ktab = iwork 3002 3092 #endif … … 3005 3095 3006 3096 3007 SUBROUTINE mppmin_a_int( ktab, kdim ) 3097 SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 3098 !!---------------------------------------------------------------------- 3099 !! *** routine mppmax_a_int *** 3100 !! 3101 !! ** Purpose : Find maximum value in an integer layout array 3102 !! 3103 !!---------------------------------------------------------------------- 3104 !! * Arguments 3105 INTEGER , INTENT( in ) :: kdim ! size of array 3106 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 3107 INTEGER , INTENT(in) , OPTIONAL :: kcom 3108 3109 #if defined key_mpp_shmem 3110 !! * Local declarations (SHMEM version) 3111 INTEGER :: ji 3112 INTEGER, SAVE :: ibool=0 3113 3114 IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_int routine : kdim is too big', & 3115 & 'change jpmppsum dimension in mpp.h' ) 3116 3117 DO ji = 1, kdim 3118 niltab_shmem(ji) = ktab(ji) 3119 END DO 3120 CALL barrier() 3121 IF(ibool == 0 ) THEN 3122 CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0 & 3123 ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 3124 ELSE 3125 CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0 & 3126 ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 3127 ENDIF 3128 CALL barrier() 3129 ibool=ibool+1 3130 ibool=MOD( ibool,2) 3131 DO ji = 1, kdim 3132 ktab(ji) = niltab_shmem(ji) 3133 END DO 3134 3135 # elif defined key_mpp_mpi 3136 3137 !! * Local variables (MPI version) 3138 INTEGER :: ierror 3139 INTEGER :: localcomm 3140 INTEGER, DIMENSION(kdim) :: iwork 3141 3142 localcomm = mpi_comm_opa 3143 IF( PRESENT(kcom) ) localcomm = kcom 3144 3145 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, & 3146 & mpi_max, localcomm, ierror ) 3147 3148 ktab(:) = iwork(:) 3149 #endif 3150 3151 END SUBROUTINE mppmax_a_int 3152 3153 3154 SUBROUTINE mppmax_int( ktab, kcom ) 3155 !!---------------------------------------------------------------------- 3156 !! *** routine mppmax_int *** 3157 !! 3158 !! ** Purpose : 3159 !! Massively parallel processors 3160 !! Find maximum value in an integer layout array 3161 !! 3162 !!---------------------------------------------------------------------- 3163 !! * Arguments 3164 INTEGER, INTENT(inout) :: ktab ! ??? 3165 INTEGER, INTENT(in), OPTIONAL :: kcom ! ??? 3166 3167 !! * Local declarations 3168 3169 #if defined key_mpp_shmem 3170 3171 !! * Local variables (SHMEM version) 3172 INTEGER :: ji 3173 INTEGER, SAVE :: ibool=0 3174 3175 niltab_shmem(1) = ktab 3176 CALL barrier() 3177 IF(ibool == 0 ) THEN 3178 CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0 & 3179 ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 3180 ELSE 3181 CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0 & 3182 ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 3183 ENDIF 3184 CALL barrier() 3185 ibool=ibool+1 3186 ibool=MOD( ibool,2) 3187 ktab = niltab_shmem(1) 3188 3189 # elif defined key_mpp_mpi 3190 3191 !! * Local variables (MPI version) 3192 INTEGER :: ierror, iwork 3193 INTEGER :: localcomm 3194 3195 localcomm = mpi_comm_opa 3196 IF( PRESENT(kcom) ) localcomm = kcom 3197 3198 CALL mpi_allreduce(ktab,iwork, 1,mpi_integer & 3199 & ,mpi_max,localcomm,ierror) 3200 3201 ktab = iwork 3202 #endif 3203 3204 END SUBROUTINE mppmax_int 3205 3206 3207 SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 3008 3208 !!---------------------------------------------------------------------- 3009 3209 !! *** routine mppmin_a_int *** … … 3015 3215 INTEGER , INTENT( in ) :: kdim ! size of array 3016 3216 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 3217 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 3017 3218 3018 3219 #if defined key_mpp_shmem … … 3046 3247 !! * Local variables (MPI version) 3047 3248 INTEGER :: ierror 3249 INTEGER :: localcomm 3048 3250 INTEGER, DIMENSION(kdim) :: iwork 3049 3251 3252 localcomm = mpi_comm_opa 3253 IF( PRESENT(kcom) ) localcomm = kcom 3254 3050 3255 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, & 3051 & mpi_min, mpi_comm_world, ierror )3256 & mpi_min, localcomm, ierror ) 3052 3257 3053 3258 ktab(:) = iwork(:) … … 3097 3302 3098 3303 CALL mpi_allreduce(ktab,iwork, 1,mpi_integer & 3099 & ,mpi_min,mpi_comm_ world,ierror)3304 & ,mpi_min,mpi_comm_opa,ierror) 3100 3305 3101 3306 ktab = iwork … … 3151 3356 3152 3357 CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer & 3153 ,mpi_sum,mpi_comm_ world,ierror)3358 ,mpi_sum,mpi_comm_opa,ierror) 3154 3359 3155 3360 ktab(:) = iwork(:) … … 3194 3399 3195 3400 CALL mpi_allreduce(ktab,iwork, 1,mpi_integer & 3196 ,mpi_sum,mpi_comm_ world,ierror)3401 ,mpi_sum,mpi_comm_opa,ierror) 3197 3402 3198 3403 ktab = iwork … … 3262 3467 CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 3263 3468 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3264 ,mpi_isl,mpi_comm_ world,ierror)3469 ,mpi_isl,mpi_comm_opa,ierror) 3265 3470 ptab(:) = zwork(:) 3266 3471 … … 3320 3525 CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 3321 3526 CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, & 3322 & mpi_isl , mpi_comm_ world, ierror )3527 & mpi_isl , mpi_comm_opa, ierror ) 3323 3528 ptab = zwork 3324 3529 … … 3328 3533 3329 3534 3330 FUNCTION lc_isl( py, px, kdim , kdtatyp)3535 FUNCTION lc_isl( py, px, kdim ) 3331 3536 INTEGER :: kdim 3332 3537 REAL(wp), DIMENSION(kdim) :: px, py … … 3341 3546 3342 3547 3343 SUBROUTINE mppmax_a_real( ptab, kdim )3548 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 3344 3549 !!---------------------------------------------------------------------- 3345 3550 !! *** routine mppmax_a_real *** … … 3351 3556 INTEGER , INTENT( in ) :: kdim 3352 3557 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 3558 INTEGER , INTENT( in ), OPTIONAL :: kcom 3353 3559 3354 3560 #if defined key_mpp_shmem … … 3383 3589 !! * Local variables (MPI version) 3384 3590 INTEGER :: ierror 3591 INTEGER :: localcomm 3385 3592 REAL(wp), DIMENSION(kdim) :: zwork 3386 3593 3594 localcomm = mpi_comm_opa 3595 IF( PRESENT(kcom) ) localcomm = kcom 3596 3387 3597 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3388 ,mpi_max, mpi_comm_world,ierror)3598 ,mpi_max,localcomm,ierror) 3389 3599 ptab(:) = zwork(:) 3390 3600 … … 3394 3604 3395 3605 3396 SUBROUTINE mppmax_real( ptab )3606 SUBROUTINE mppmax_real( ptab, kcom ) 3397 3607 !!---------------------------------------------------------------------- 3398 3608 !! *** routine mppmax_real *** … … 3403 3613 !! * Arguments 3404 3614 REAL(wp), INTENT(inout) :: ptab ! ??? 3615 INTEGER , INTENT( in ), OPTIONAL :: kcom ! ??? 3405 3616 3406 3617 #if defined key_mpp_shmem … … 3427 3638 !! * Local variables (MPI version) 3428 3639 INTEGER :: ierror 3640 INTEGER :: localcomm 3429 3641 REAL(wp) :: zwork 3430 3642 3643 localcomm = mpi_comm_opa 3644 IF( PRESENT(kcom) ) localcomm = kcom 3645 3431 3646 CALL mpi_allreduce( ptab, zwork , 1 , mpi_double_precision, & 3432 & mpi_max, mpi_comm_world, ierror )3647 & mpi_max, localcomm, ierror ) 3433 3648 ptab = zwork 3434 3649 … … 3438 3653 3439 3654 3440 SUBROUTINE mppmin_a_real( ptab, kdim )3655 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 3441 3656 !!---------------------------------------------------------------------- 3442 3657 !! *** routine mppmin_a_real *** … … 3448 3663 INTEGER , INTENT( in ) :: kdim 3449 3664 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 3665 INTEGER , INTENT( in ), OPTIONAL :: kcom 3450 3666 3451 3667 #if defined key_mpp_shmem … … 3480 3696 !! * Local variables (MPI version) 3481 3697 INTEGER :: ierror 3698 INTEGER :: localcomm 3482 3699 REAL(wp), DIMENSION(kdim) :: zwork 3483 3700 3701 localcomm = mpi_comm_opa 3702 IF( PRESENT(kcom) ) localcomm = kcom 3703 3484 3704 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3485 ,mpi_min, mpi_comm_world,ierror)3705 ,mpi_min,localcomm,ierror) 3486 3706 ptab(:) = zwork(:) 3487 3707 … … 3491 3711 3492 3712 3493 SUBROUTINE mppmin_real( ptab )3713 SUBROUTINE mppmin_real( ptab, kcom ) 3494 3714 !!---------------------------------------------------------------------- 3495 3715 !! *** routine mppmin_real *** … … 3501 3721 !! * Arguments 3502 3722 REAL(wp), INTENT( inout ) :: ptab ! 3723 INTEGER , INTENT( in ), OPTIONAL :: kcom 3503 3724 3504 3725 #if defined key_mpp_shmem … … 3526 3747 INTEGER :: ierror 3527 3748 REAL(wp) :: zwork 3749 INTEGER :: localcomm 3750 3751 localcomm = mpi_comm_opa 3752 IF( PRESENT(kcom) ) localcomm = kcom 3528 3753 3529 3754 CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision & 3530 & ,mpi_min, mpi_comm_world,ierror)3755 & ,mpi_min,localcomm,ierror) 3531 3756 ptab = zwork 3532 3757 … … 3536 3761 3537 3762 3538 SUBROUTINE mppsum_a_real( ptab, kdim )3763 SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 3539 3764 !!---------------------------------------------------------------------- 3540 3765 !! *** routine mppsum_a_real *** … … 3546 3771 INTEGER , INTENT( in ) :: kdim ! size of ptab 3547 3772 REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array 3773 INTEGER , INTENT( in ), OPTIONAL :: kcom 3548 3774 3549 3775 #if defined key_mpp_shmem … … 3578 3804 !! * Local variables (MPI version) 3579 3805 INTEGER :: ierror ! temporary integer 3806 INTEGER :: localcomm 3580 3807 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace 3808 3809 3810 localcomm = mpi_comm_opa 3811 IF( PRESENT(kcom) ) localcomm = kcom 3581 3812 3582 3813 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3583 & ,mpi_sum, mpi_comm_world,ierror)3814 & ,mpi_sum,localcomm,ierror) 3584 3815 ptab(:) = zwork(:) 3585 3816 … … 3589 3820 3590 3821 3591 SUBROUTINE mppsum_real( ptab )3822 SUBROUTINE mppsum_real( ptab, kcom ) 3592 3823 !!---------------------------------------------------------------------- 3593 3824 !! *** routine mppsum_real *** … … 3598 3829 !!----------------------------------------------------------------------- 3599 3830 REAL(wp), INTENT(inout) :: ptab ! input scalar 3831 INTEGER , INTENT( in ), OPTIONAL :: kcom 3600 3832 3601 3833 #if defined key_mpp_shmem … … 3622 3854 !! * Local variables (MPI version) 3623 3855 INTEGER :: ierror 3856 INTEGER :: localcomm 3624 3857 REAL(wp) :: zwork 3625 3858 3626 CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision & 3627 & ,mpi_sum,mpi_comm_world,ierror) 3859 localcomm = mpi_comm_opa 3860 IF( PRESENT(kcom) ) localcomm = kcom 3861 3862 CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision & 3863 & ,mpi_sum,localcomm,ierror) 3628 3864 ptab = zwork 3629 3865 … … 3672 3908 zain(2,:)=ki+10000.*kj 3673 3909 3674 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_ WORLD,ierror)3910 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 3675 3911 3676 3912 pmin=zaout(1,1) … … 3723 3959 zain(2,:)=ki+10000.*kj+100000000.*kk 3724 3960 3725 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_ WORLD,ierror)3961 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 3726 3962 3727 3963 pmin=zaout(1,1) … … 3774 4010 zain(2,:)=ki+10000.*kj 3775 4011 3776 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_ WORLD,ierror)4012 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 3777 4013 3778 4014 pmax=zaout(1,1) … … 3824 4060 zain(2,:)=ki+10000.*kj+100000000.*kk 3825 4061 3826 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_ WORLD,ierror)4062 CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 3827 4063 3828 4064 pmax=zaout(1,1) … … 3852 4088 INTEGER :: ierror 3853 4089 3854 CALL mpi_barrier(mpi_comm_ world,ierror)4090 CALL mpi_barrier(mpi_comm_opa,ierror) 3855 4091 3856 4092 #endif … … 4125 4361 END SUBROUTINE mppobc 4126 4362 4363 SUBROUTINE mpp_comm_free( kcom) 4364 4365 INTEGER, INTENT(in) :: kcom 4366 INTEGER :: ierr 4367 4368 CALL MPI_COMM_FREE(kcom, ierr) 4369 4370 END SUBROUTINE mpp_comm_free 4371 4372 4373 SUBROUTINE mpp_ini_ice(pindic) 4374 !!---------------------------------------------------------------------- 4375 !! *** routine mpp_ini_ice *** 4376 !! 4377 !! ** Purpose : Initialize special communicator for ice areas 4378 !! condition together with global variables needed in the ddmpp folding 4379 !! 4380 !! ** Method : - Look for ice processors in ice routines 4381 !! - Put their number in nrank_ice 4382 !! - Create groups for the world processors and the ice processors 4383 !! - Create a communicator for ice processors 4384 !! 4385 !! ** output 4386 !! njmppmax = njmpp for northern procs 4387 !! ndim_rank_ice = number of processors in the northern line 4388 !! nrank_north (ndim_rank_north) = number of the northern procs. 4389 !! ngrp_world = group ID for the world processors 4390 !! ngrp_ice = group ID for the ice processors 4391 !! ncomm_ice = communicator for the ice procs. 4392 !! n_ice_root = number (in the world) of proc 0 in the ice comm. 4393 !! 4394 !! History : 4395 !! ! 03-09 (J.M. Molines, MPI only ) 4396 !!---------------------------------------------------------------------- 4397 #ifdef key_mpp_shmem 4398 CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' ) 4399 # elif key_mpp_mpi 4400 INTEGER, INTENT(in) :: pindic 4401 INTEGER :: ierr 4402 INTEGER :: jproc 4403 INTEGER :: ii 4404 INTEGER, DIMENSION(jpnij) :: kice 4405 INTEGER, DIMENSION(jpnij) :: zwork 4406 !!---------------------------------------------------------------------- 4407 4408 ! Look for how many procs with sea-ice 4409 ! 4410 kice = 0 4411 DO jproc=1,jpnij 4412 IF(jproc == narea .AND. pindic .GT. 0) THEN 4413 kice(jproc) = 1 4414 ENDIF 4415 END DO 4416 4417 zwork = 0 4418 CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer, & 4419 mpi_sum, mpi_comm_opa, ierr ) 4420 ndim_rank_ice = sum(zwork) 4421 4422 ! Allocate the right size to nrank_north 4423 #if ! defined key_agrif 4424 IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice) 4425 #else 4426 DEALLOCATE(nrank_ice) 4427 #endif 4428 4429 ALLOCATE(nrank_ice(ndim_rank_ice)) 4430 4431 ii = 0 4432 nrank_ice = 0 4433 DO jproc=1,jpnij 4434 IF(zwork(jproc) == 1) THEN 4435 ii = ii + 1 4436 nrank_ice(ii) = jproc -1 4437 ENDIF 4438 END DO 4439 4440 ! Create the world group 4441 CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 4442 4443 ! Create the ice group from the world group 4444 CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr) 4445 4446 ! Create the ice communicator , ie the pool of procs with sea-ice 4447 CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr) 4448 4449 ! Find proc number in the world of proc 0 in the north 4450 ! The following line seems to be useless, we just comment & keep it as reminder 4451 ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 4452 #endif 4453 4454 END SUBROUTINE mpp_ini_ice 4455 4127 4456 4128 4457 SUBROUTINE mpp_ini_north … … 4186 4515 ! create the world group 4187 4516 ! 4188 CALL MPI_COMM_GROUP(mpi_comm_ world,ngrp_world,ierr)4517 CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 4189 4518 ! 4190 4519 ! Create the North group from the world group … … 4193 4522 ! Create the North communicator , ie the pool of procs in the north group 4194 4523 ! 4195 CALL MPI_COMM_CREATE(mpi_comm_ world,ngrp_north,ncomm_north,ierr)4524 CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr) 4196 4525 4197 4526 … … 4957 5286 END SUBROUTINE mpp_lbc_north_e 4958 5287 4959 4960 !!!!!4961 4962 4963 !!4964 !! This is valid on IBM machine ONLY.4965 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*- Mode: F90 -*- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!4966 !! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque4967 !! MPI afin de faire, en plus de l'initialisation de4968 !! l'environnement MPI, l'allocation d'une zone tampon4969 !! qui sera ulterieurement utilisee automatiquement lors4970 !! de tous les envois de messages par MPI_BSEND4971 !!4972 !! Auteur : CNRS/IDRIS4973 !! Date : Tue Nov 13 12:02:14 20014974 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!4975 4976 5288 SUBROUTINE mpi_init_opa(code) 4977 IMPLICIT NONE 4978 4979 !$AGRIF_DO_NOT_TREAT 4980 # include <mpif.h> 4981 !$AGRIF_END_DO_NOT_TREAT 4982 4983 INTEGER :: code,rang 5289 !!--------------------------------------------------------------------- 5290 !! *** routine mpp_init.opa *** 5291 !! 5292 !! ** Purpose :: export and attach a MPI buffer for bsend 5293 !! 5294 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment 5295 !! but classical mpi_init 5296 !! 5297 !! History :: 01/11 :: IDRIS initial version for IBM only 5298 !! 08/04 :: R. Benshila, generalisation 5299 !! 5300 !!--------------------------------------------------------------------- 5301 5302 INTEGER :: code, ierr 5303 LOGICAL :: mpi_was_called 4984 5304 4985 ! La valeur suivante doit etre au moins egale a la taille 4986 ! du plus grand message qui sera transfere dans le programme 4987 ! (de toute facon, il y aura un message d'erreur si cette 4988 ! valeur s'avere trop petite) 4989 INTEGER :: taille_tampon 4990 CHARACTER(len=9) :: taille_tampon_alphanum 4991 REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon 4992 4993 ! Le point d'entree dans la bibliotheque MPI elle-meme 4994 CALL mpi_init(code) 4995 4996 ! La definition de la zone tampon pour les futurs envois 4997 ! par MPI_BSEND (on alloue une fois pour toute cette zone 4998 ! tampon, qui sera automatiquement utilisee lors de chaque 4999 ! appel a MPI_BSEND). 5000 ! La desallocation sera implicite quand on sortira de 5001 ! l'environnement MPI. 5002 5003 ! Recuperation de la valeur de la variable d'environnement 5004 ! BUFFER_LENGTH 5005 ! qui, si elle est definie, doit contenir une valeur superieure 5006 ! a la taille en octets du plus gros message 5007 CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum) 5008 5009 ! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par 5010 ! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit 5011 ! 65 536 octets 5012 IF (taille_tampon_alphanum == ' ') THEN 5013 taille_tampon = 65536 5014 ELSE 5015 READ(taille_tampon_alphanum,'(i9)') taille_tampon 5016 END IF 5017 5018 ! On est limite en mode d'adressage 32 bits a 1750 Mo pour la zone 5019 ! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo 5020 IF (taille_tampon > 210000000) THEN 5021 PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000' 5022 CALL mpi_abort(MPI_COMM_WORLD,2,code) 5023 END IF 5024 5025 CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code) 5026 IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon 5027 5028 ! Allocation du tampon et attachement 5029 ALLOCATE(tampon(taille_tampon)) 5030 CALL mpi_buffer_attach(tampon,taille_tampon,code) 5305 ! MPI initialization 5306 CALL mpi_initialized(mpi_was_called, code) 5307 IF ( code /= MPI_SUCCESS ) THEN 5308 CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 5309 CALL mpi_abort( mpi_comm_world, code, ierr ) 5310 ENDIF 5311 5312 IF ( .NOT. mpi_was_called ) THEN 5313 CALL mpi_init(code) 5314 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 5315 IF ( code /= MPI_SUCCESS ) THEN 5316 CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 5317 CALL mpi_abort( mpi_comm_world, code, ierr ) 5318 ENDIF 5319 ENDIF 5320 5321 IF( nn_buffer > 0 ) THEN 5322 IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of : ', nn_buffer 5323 5324 ! Buffer allocation and attachment 5325 ALLOCATE(tampon(nn_buffer)) 5326 CALL mpi_buffer_attach(tampon,nn_buffer,code) 5327 ENDIF 5031 5328 5032 5329 END SUBROUTINE mpi_init_opa … … 5040 5337 END INTERFACE 5041 5338 INTERFACE mpp_max 5042 MODULE PROCEDURE mppmax_a_ real, mppmax_real5339 MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 5043 5340 END INTERFACE 5044 5341 INTERFACE mpp_min … … 5060 5357 5061 5358 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 5359 INTEGER :: ncomm_ice 5062 5360 5063 5361 CONTAINS 5064 5362 5065 FUNCTION mynode() RESULT (function_value) 5363 FUNCTION mynode(localComm) RESULT (function_value) 5364 INTEGER, OPTIONAL :: localComm 5066 5365 function_value = 0 5067 5366 END FUNCTION mynode … … 5070 5369 END SUBROUTINE mppsync 5071 5370 5072 SUBROUTINE mpp_sum_as( parr, kdim ) ! Dummy routine5371 SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine 5073 5372 REAL , DIMENSION(:) :: parr 5074 5373 INTEGER :: kdim 5075 WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1) 5374 INTEGER, OPTIONAL :: kcom 5375 WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 5076 5376 END SUBROUTINE mpp_sum_as 5077 5377 5078 SUBROUTINE mpp_sum_a2s( parr, kdim ) ! Dummy routine5378 SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine 5079 5379 REAL , DIMENSION(:,:) :: parr 5080 5380 INTEGER :: kdim 5081 WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1) 5381 INTEGER, OPTIONAL :: kcom 5382 WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 5082 5383 END SUBROUTINE mpp_sum_a2s 5083 5384 5084 SUBROUTINE mpp_sum_ai( karr, kdim ) ! Dummy routine5385 SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine 5085 5386 INTEGER, DIMENSION(:) :: karr 5086 5387 INTEGER :: kdim 5087 WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1) 5388 INTEGER, OPTIONAL :: kcom 5389 WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 5088 5390 END SUBROUTINE mpp_sum_ai 5089 5391 5090 SUBROUTINE mpp_sum_s( psca ) ! Dummy routine5392 SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine 5091 5393 REAL :: psca 5092 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca 5394 INTEGER, OPTIONAL :: kcom 5395 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 5093 5396 END SUBROUTINE mpp_sum_s 5094 5397 5095 SUBROUTINE mpp_sum_i( kint ) ! Dummy routine5398 SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine 5096 5399 integer :: kint 5097 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint 5400 INTEGER, OPTIONAL :: kcom 5401 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 5098 5402 END SUBROUTINE mpp_sum_i 5099 5403 5100 SUBROUTINE mppmax_a_real( parr, kdim )5404 SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 5101 5405 REAL , DIMENSION(:) :: parr 5102 5406 INTEGER :: kdim 5103 WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1) 5407 INTEGER, OPTIONAL :: kcom 5408 WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 5104 5409 END SUBROUTINE mppmax_a_real 5105 5410 5106 SUBROUTINE mppmax_real( psca )5411 SUBROUTINE mppmax_real( psca, kcom ) 5107 5412 REAL :: psca 5108 WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca 5413 INTEGER, OPTIONAL :: kcom 5414 WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 5109 5415 END SUBROUTINE mppmax_real 5110 5416 5111 SUBROUTINE mppmin_a_real( parr, kdim )5417 SUBROUTINE mppmin_a_real( parr, kdim, kcom ) 5112 5418 REAL , DIMENSION(:) :: parr 5113 5419 INTEGER :: kdim 5114 WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1) 5420 INTEGER, OPTIONAL :: kcom 5421 WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 5115 5422 END SUBROUTINE mppmin_a_real 5116 5423 5117 SUBROUTINE mppmin_real( psca )5424 SUBROUTINE mppmin_real( psca, kcom ) 5118 5425 REAL :: psca 5119 WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca 5426 INTEGER, OPTIONAL :: kcom 5427 WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 5120 5428 END SUBROUTINE mppmin_real 5121 5429 5122 SUBROUTINE mppm in_a_int( karr, kdim)5430 SUBROUTINE mppmax_a_int( karr, kdim ,kcom) 5123 5431 INTEGER, DIMENSION(:) :: karr 5124 5432 INTEGER :: kdim 5125 WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1) 5433 INTEGER, OPTIONAL :: kcom 5434 WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 5435 END SUBROUTINE mppmax_a_int 5436 5437 SUBROUTINE mppmax_int( kint, kcom) 5438 INTEGER :: kint 5439 INTEGER, OPTIONAL :: kcom 5440 WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 5441 END SUBROUTINE mppmax_int 5442 5443 SUBROUTINE mppmin_a_int( karr, kdim, kcom ) 5444 INTEGER, DIMENSION(:) :: karr 5445 INTEGER :: kdim 5446 INTEGER, OPTIONAL :: kcom 5447 WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 5126 5448 END SUBROUTINE mppmin_a_int 5127 5449 5128 SUBROUTINE mppmin_int( kint )5450 SUBROUTINE mppmin_int( kint, kcom ) 5129 5451 INTEGER :: kint 5130 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint 5452 INTEGER, OPTIONAL :: kcom 5453 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 5131 5454 END SUBROUTINE mppmin_int 5132 5455 … … 5223 5546 END SUBROUTINE mppstop 5224 5547 5548 SUBROUTINE mpp_ini_ice(kcom) 5549 INTEGER :: kcom 5550 WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?',kcom 5551 END SUBROUTINE mpp_ini_ice 5552 5553 SUBROUTINE mpp_comm_free(kcom) 5554 INTEGER :: kcom 5555 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?',kcom 5556 END SUBROUTINE mpp_comm_free 5557 5225 5558 #endif 5226 5559 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.
