Changeset 2715 for trunk/NEMOGCM/NEMO/OPA_SRC/LBC
- Timestamp:
- 2011-03-30T17:58:35+02:00 (13 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OPA_SRC/LBC
- Files:
-
- 4 edited
-
cla.F90 (modified) (5 diffs)
-
lbcnfd.F90 (modified) (1 diff)
-
lib_mpp.F90 (modified) (37 diffs)
-
mppini.F90 (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/LBC/cla.F90
r2442 r2715 31 31 USE lib_mpp ! distributed memory computing library 32 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 USE lib_mpp ! MPP library 33 34 34 35 IMPLICIT NONE … … 43 44 ! ! for Bab-el-Mandeb, Gibraltar, and Hormuz straits 44 45 45 ! 46 REAL(wp), DIMENSION (jpk) :: hdiv_139_101, hdiv_139_101_kt ! Gibraltar strait, fixed & time evolving part(i,j)=(172,101)47 REAL(wp), DIMENSION (jpk) :: hdiv_139_102 ! Gibraltar strait, fixed part only(i,j)=(139,102)48 REAL(wp), DIMENSION (jpk) :: hdiv_141_102, hdiv_141_102_kt ! Gibraltar strait, fixed & time evolving part(i,j)=(141,102)49 REAL(wp), DIMENSION (jpk) :: hdiv_161_88 , hdiv_161_88_kt ! Bab-el-Mandeb strait, fixed & time evolving part(i,j)=(161,88)50 REAL(wp), DIMENSION (jpk) :: hdiv_161_87 ! Bab-el-Mandeb strait, fixed part only(i,j)=(161,87)51 REAL(wp), DIMENSION (jpk) :: hdiv_160_89 , hdiv_160_89_kt ! Bab-el-Mandeb strait, fixed & time evolving part(i,j)=(160,89)52 REAL(wp), DIMENSION (jpk) :: hdiv_172_94 ! Hormuz strait, fixed part only(i,j)=(172, 94)53 54 REAL(wp), DIMENSION (jpk) :: t_171_94_hor, s_171_94_hor ! Temperature, salinity in theHormuz strait46 ! ! fixed part ! time evolving !!! profile of hdiv for some straits 47 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_139_101, hdiv_139_101_kt ! Gibraltar (i,j)=(172,101) 48 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_139_102 ! Gibraltar (i,j)=(139,102) 49 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_141_102, hdiv_141_102_kt ! Gibraltar (i,j)=(141,102) 50 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_161_88 , hdiv_161_88_kt ! Bab-el-Mandeb (i,j)=(161,88) 51 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_161_87 ! Bab-el-Mandeb (i,j)=(161,87) 52 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_160_89 , hdiv_160_89_kt ! Bab-el-Mandeb (i,j)=(160,89) 53 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: hdiv_172_94 ! Hormuz (i,j)=(172, 94) 54 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) :: t_171_94_hor, s_171_94_hor ! Temperature, salinity in Hormuz strait 55 56 56 57 !! * Substitutions … … 177 178 !! ** Action : nbab, ngib, nhor strait inside the local domain or not 178 179 !!--------------------------------------------------------------------- 179 REAL(wp) :: ztemp 180 REAL(wp) :: ztemp ! local scalar 181 INTEGER :: ierr ! local integer 180 182 !!--------------------------------------------------------------------- 181 183 ! … … 184 186 IF(lwp) WRITE(numout,*) '~~~~~~~~~' 185 187 ! 188 ! ! Allocate arrays for this module 189 ALLOCATE( hdiv_139_101(jpk) , hdiv_139_101_kt(jpk) , & ! Gibraltar 190 & hdiv_139_102(jpk) , & 191 & hdiv_141_102(jpk) , hdiv_141_102_kt(jpk) , & 192 & hdiv_161_88 (jpk) , hdiv_161_88_kt (jpk) , & ! Bab-el-Mandeb 193 & hdiv_161_87 (jpk) , & 194 & hdiv_160_89 (jpk) , hdiv_160_89_kt (jpk) , & ! Hormuz 195 & hdiv_172_94 (jpk) , & 196 & t_171_94_hor(jpk) , s_171_94_hor (jpk) , STAT=ierr ) 197 IF( lk_mpp ) CALL mpp_sum( ierr ) 198 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'cla_init: unable to allocate arrays' ) 199 ! 186 200 IF( .NOT.lk_dynspg_flt ) CALL ctl_stop( 'cla_init: Cross Land Advection works only with lk_dynspg_flt=T ' ) 187 201 ! 188 IF( lk_vvl ) CALL ctl_stop( 'cla_init: Cross Land Advection does not work with lk_vvl=T option' )189 ! 190 IF( jpk /= 31 ) CALL ctl_stop( 'cla_init: Cross Land Advection hard coded for ORCA_R2_L31' )202 IF( lk_vvl ) CALL ctl_stop( 'cla_init: Cross Land Advection does not work with lk_vvl=T option' ) 203 ! 204 IF( jpk /= 31 ) CALL ctl_stop( 'cla_init: Cross Land Advection hard coded for ORCA_R2_L31' ) 191 205 ! 192 206 ! _|_______|_______|_ … … 723 737 !! Default key Dummy module 724 738 !!---------------------------------------------------------------------- 725 USE in_out_manager ! I/O manager739 USE lib_mpp, ONLY: ctl_stop 726 740 CONTAINS 727 741 SUBROUTINE cla_init -
trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r2442 r2715 12 12 !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) 13 13 !!---------------------------------------------------------------------- 14 USE oce ! ocean dynamics and tracers15 14 USE dom_oce ! ocean space and time domain 16 15 USE in_out_manager ! I/O manager -
trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r2481 r2715 18 18 !! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd 19 19 !! 3.2 ! 2009 (O. Marti) add mpp_ini_znl 20 !! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager 21 !!---------------------------------------------------------------------- 22 23 !!---------------------------------------------------------------------- 24 !! ctl_stop : update momentum and tracer Kz from a tke scheme 25 !! ctl_warn : initialization, namelist read, and parameters control 26 !! ctl_opn : Open file and check if required file is available. 27 !! get_unit : give the index of an unused logical unit 20 28 !!---------------------------------------------------------------------- 21 29 #if defined key_mpp_mpi … … 23 31 !! 'key_mpp_mpi' MPI massively parallel processing library 24 32 !!---------------------------------------------------------------------- 25 !! mynode : indentify the processor unit 26 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 33 !! lib_mpp_alloc : allocate mpp arrays 34 !! mynode : indentify the processor unit 35 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 27 36 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 28 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)29 !! mpprecv :30 !! mppsend : SUBROUTINE mpp_ini_znl31 !! mppscatter :32 !! mppgather :33 !! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real34 !! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real35 !! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real36 !! mpp_minloc :37 !! mpp_maxloc :38 !! mppsync :39 !! mppstop :40 !! mppobc : variant of mpp_lnk for open boundary condition37 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 38 !! mpprecv : 39 !! mppsend : SUBROUTINE mpp_ini_znl 40 !! mppscatter : 41 !! mppgather : 42 !! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real 43 !! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real 44 !! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 45 !! mpp_minloc : 46 !! mpp_maxloc : 47 !! mppsync : 48 !! mppstop : 49 !! mppobc : variant of mpp_lnk for open boundary condition 41 50 !! mpp_ini_north : initialisation of north fold 42 51 !! mpp_lbc_north : north fold processors gathering 43 52 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 44 53 !!---------------------------------------------------------------------- 45 !! History : 46 !! ! 94 (M. Guyon, J. Escobar, M. Imbard) Original code 47 !! ! 97 (A.M. Treguier) SHMEM additions 48 !! ! 98 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 49 !! 9.0 ! 03 (J.-M. Molines, G. Madec) F90, free form 50 !! ! 04 (R. Bourdalle Badie) isend option in mpi 51 !! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases 52 !! ! 05 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort 53 !! ! 09 (R. Benshila) SHMEM suppression, north fold in lbc_nfd 54 !!---------------------------------------------------------------------- 55 USE dom_oce ! ocean space and time domain 56 USE in_out_manager ! I/O manager 57 USE lbcnfd ! north fold treatment 54 USE dom_oce ! ocean space and time domain 55 USE lbcnfd ! north fold treatment 56 USE in_out_manager ! I/O manager 58 57 59 58 IMPLICIT NONE 60 59 PRIVATE 61 60 61 PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn 62 62 PUBLIC mynode, mppstop, mppsync, mpp_comm_free 63 63 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e … … 65 65 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 66 66 PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl 67 PUBLIC mppsize 68 PUBLIC lib_mpp_alloc ! Called in nemogcm.F90 67 69 68 70 !! * Interfaces … … 120 122 INTEGER :: ndim_rank_ice ! number of 'ice' processors 121 123 INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm 122 INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_ice ! dimension ndim_rank_ice124 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice 123 125 124 126 ! variables used for zonal integration … … 127 129 INTEGER :: ngrp_znl ! group ID for the znl processors 128 130 INTEGER :: ndim_rank_znl ! number of processors on the same zonal average 129 INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain131 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 130 132 131 133 ! North fold condition in mpp_mpi with jpni > 1 … … 137 139 INTEGER :: njmppmax ! value of njmpp for the processors of the northern line 138 140 INTEGER :: north_root ! number (in the comm_opa) of proc 0 in the northern comm 139 INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_north ! dimension ndim_rank_north141 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dimension ndim_rank_north 140 142 141 143 ! Type of send : standard, buffered, immediate … … 144 146 INTEGER :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend 145 147 146 REAL(wp), ALLOCATABLE, DIMENSION(:):: tampon ! buffer in case of bsend148 REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend 147 149 148 150 ! message passing arrays 149 REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: t4ns, t4sn ! 2 x 3d for north-south & south-north 150 REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) :: t4ew, t4we ! 2 x 3d for east-west & west-east 151 REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: t4p1, t4p2 ! 2 x 3d for north fold 152 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: t3ns, t3sn ! 3d for north-south & south-north 153 REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: t3ew, t3we ! 3d for east-west & west-east 154 REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: t3p1, t3p2 ! 3d for north fold 155 REAL(wp), DIMENSION(jpi,jprecj,2) :: t2ns, t2sn ! 2d for north-south & south-north 156 REAL(wp), DIMENSION(jpj,jpreci,2) :: t2ew, t2we ! 2d for east-west & west-east 157 REAL(wp), DIMENSION(jpi,jprecj,2) :: t2p1, t2p2 ! 2d for north fold 158 REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) :: tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo 159 REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) :: tr2ew, tr2we ! 2d for east-west & west-east + extra outer halo 151 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ns, t4sn ! 2 x 3d for north-south & south-north 152 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ew, t4we ! 2 x 3d for east-west & west-east 153 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4p1, t4p2 ! 2 x 3d for north fold 154 REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ns, t3sn ! 3d for north-south & south-north 155 REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ew, t3we ! 3d for east-west & west-east 156 REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3p1, t3p2 ! 3d for north fold 157 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ns, t2sn ! 2d for north-south & south-north 158 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ew, t2we ! 2d for east-west & west-east 159 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2p1, t2p2 ! 2d for north fold 160 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo 161 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tr2ew, tr2we ! 2d for east-west & west-east + extra outer halo 162 163 ! Arrays used in mpp_lbc_north_3d() 164 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztab, znorthloc 165 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio 166 167 ! Arrays used in mpp_lbc_north_2d() 168 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_2d, znorthloc_2d 169 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_2d 170 171 ! Arrays used in mpp_lbc_north_e() 172 REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_e, znorthloc_e 173 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_e 174 160 175 !!---------------------------------------------------------------------- 161 176 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 162 177 !! $Id$ 163 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)178 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 164 179 !!---------------------------------------------------------------------- 165 166 180 CONTAINS 167 181 168 FUNCTION mynode(ldtxt, localComm) 182 INTEGER FUNCTION lib_mpp_alloc( kumout ) 183 !!---------------------------------------------------------------------- 184 !! *** routine lib_mpp_alloc *** 185 !!---------------------------------------------------------------------- 186 INTEGER, INTENT(in) :: kumout ! ocean.output logical unit 187 !!---------------------------------------------------------------------- 188 ! 189 ALLOCATE( t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) , & 190 & t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2) , & 191 & t4p1(jpi,jprecj,jpk,2,2) , t4p2(jpi,jprecj,jpk,2,2) , & 192 & t3ns(jpi,jprecj,jpk,2) , t3sn(jpi,jprecj,jpk,2) , & 193 & t3ew(jpj,jpreci,jpk,2) , t3we(jpj,jpreci,jpk,2) , & 194 & t3p1(jpi,jprecj,jpk,2) , t3p2(jpi,jprecj,jpk,2) , & 195 & t2ns(jpi,jprecj ,2) , t2sn(jpi,jprecj ,2) , & 196 & t2ew(jpj,jpreci ,2) , t2we(jpj,jpreci ,2) , & 197 & t2p1(jpi,jprecj ,2) , t2p2(jpi,jprecj ,2) , & 198 ! 199 & tr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) , & 200 & tr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) , & 201 & tr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) , & 202 & tr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) , & 203 ! 204 & ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) , & 205 ! 206 & ztab_2d(jpiglo,4) , znorthloc_2d(jpi,4) , znorthgloio_2d(jpi,4,jpni) , & 207 ! 208 & ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) , & 209 ! 210 & STAT=lib_mpp_alloc ) 211 ! 212 IF( lib_mpp_alloc /= 0 ) THEN 213 WRITE(kumout,cform_war) 214 WRITE(kumout,*) 'lib_mpp_alloc : failed to allocate arrays' 215 ENDIF 216 ! 217 END FUNCTION lib_mpp_alloc 218 219 220 FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) 169 221 !!---------------------------------------------------------------------- 170 222 !! *** routine mynode *** 171 223 !! 172 224 !! ** Purpose : Find processor unit 173 !!174 225 !!---------------------------------------------------------------------- 175 226 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 227 INTEGER , INTENT(in ) :: kumnam ! namelist logical unit 228 INTEGER , INTENT(inout) :: kstop ! stop indicator 176 229 INTEGER, OPTIONAL , INTENT(in ) :: localComm 230 ! 177 231 INTEGER :: mynode, ierr, code, ji, ii 178 232 LOGICAL :: mpi_was_called 179 180 NAMELIST/nammpp/ cn_mpi_send, nn_buffer 233 ! 234 NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij 181 235 !!---------------------------------------------------------------------- 182 236 ! … … 186 240 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 187 241 ! 188 REWIND( numnam ) ! Namelist namrun : parameters of the run 189 READ ( numnam, nammpp ) 242 jpni = -1; jpnj = -1; jpnij = -1 243 REWIND( kumnam ) ! Namelist namrun : parameters of the run 244 READ ( kumnam, nammpp ) 190 245 ! ! control print 191 246 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 192 247 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 193 248 WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer ; ii = ii + 1 249 250 IF(jpnij < 1)THEN 251 ! If jpnij is not specified in namelist then we calculate it - this 252 ! means there will be no land cutting out. 253 jpnij = jpni * jpnj 254 END IF 255 256 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 257 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1 258 ELSE 259 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni; ii = ii + 1 260 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj; ii = ii + 1 261 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij; ii = ii +1 262 END IF 194 263 195 264 CALL mpi_initialized ( mpi_was_called, code ) … … 217 286 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 218 287 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 219 nstop = nstop + 1288 kstop = kstop + 1 220 289 END SELECT 221 290 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 222 291 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 223 292 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 224 nstop = nstop + 1293 kstop = kstop + 1 225 294 ELSE 226 295 SELECT CASE ( cn_mpi_send ) … … 238 307 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 239 308 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 240 nstop = nstop + 1309 kstop = kstop + 1 241 310 END SELECT 242 311 ! … … 1650 1719 1651 1720 1652 SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )1721 SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout) 1653 1722 !!---------------------------------------------------------------------- 1654 1723 !! *** routine mppobc *** … … 1670 1739 !! 1671 1740 !!---------------------------------------------------------------------- 1741 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 1742 USE wrk_nemo, ONLY: ztab => wrk_2d_1 1743 ! 1672 1744 INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices 1673 1745 INTEGER , INTENT(in ) :: kl ! index of open boundary … … 1676 1748 ! ! = 1 north/south ; = 2 east/west 1677 1749 INTEGER , INTENT(in ) :: kij ! horizontal dimension 1750 INTEGER , INTENT(in ) :: kumout ! ocean.output logical unit 1678 1751 REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array 1679 ! !1680 INTEGER :: ji, jj, jk, jl! dummy loop indices1681 INTEGER :: iipt0, iipt1, ilpt1 ! temporaryintegers1682 INTEGER :: ijpt0, ijpt1 ! --1683 INTEGER :: imigr, iihom, ijhom ! --1752 ! 1753 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1754 INTEGER :: iipt0, iipt1, ilpt1 ! local integers 1755 INTEGER :: ijpt0, ijpt1 ! - - 1756 INTEGER :: imigr, iihom, ijhom ! - - 1684 1757 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1685 1758 INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend 1686 REAL(wp), DIMENSION(jpi,jpj) :: ztab ! temporary workspace 1687 !!---------------------------------------------------------------------- 1759 !!---------------------------------------------------------------------- 1760 1761 IF( wrk_in_use(2, 1) ) THEN 1762 WRITE(kumout, cform_err) 1763 WRITE(kumout,*) 'mppobc : requested workspace array unavailable' 1764 CALL mppstop 1765 ENDIF 1688 1766 1689 1767 ! boundary condition initialization … … 1704 1782 ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) ) 1705 1783 ELSE 1706 CALL ctl_stop( 'mppobc: bad ktype' ) 1784 WRITE(kumout, cform_err) 1785 WRITE(kumout,*) 'mppobc : bad ktype' 1786 CALL mppstop 1707 1787 ENDIF 1708 1788 … … 1834 1914 END DO 1835 1915 ! 1916 IF( wrk_not_released(2, 1) ) THEN 1917 WRITE(kumout, cform_err) 1918 WRITE(kumout,*) 'mppobc : failed to release workspace array' 1919 CALL mppstop 1920 ENDIF 1921 ! 1836 1922 END SUBROUTINE mppobc 1837 1923 … … 1850 1936 1851 1937 1852 SUBROUTINE mpp_ini_ice( pindic )1938 SUBROUTINE mpp_ini_ice( pindic, kumout ) 1853 1939 !!---------------------------------------------------------------------- 1854 1940 !! *** routine mpp_ini_ice *** … … 1872 1958 !! 1873 1959 !!---------------------------------------------------------------------- 1874 INTEGER, INTENT(in) :: pindic1875 !!1876 INTEGER :: ierr1960 INTEGER, INTENT(in) :: pindic 1961 INTEGER, INTENT(in) :: kumout ! ocean.output logical unit 1962 !! 1877 1963 INTEGER :: jjproc 1878 INTEGER :: ii 1879 INTEGER, DIMENSION(jpnij) :: kice 1880 INTEGER, DIMENSION(jpnij) :: zwork 1881 !!---------------------------------------------------------------------- 1882 ! 1964 INTEGER :: ii, ierr 1965 INTEGER, ALLOCATABLE, DIMENSION(:) :: kice 1966 INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork 1967 !!---------------------------------------------------------------------- 1968 ! 1969 ! Since this is just an init routine and these arrays are of length jpnij 1970 ! then don't use wrk_nemo module - just allocate and deallocate. 1971 ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr ) 1972 IF( ierr /= 0 ) THEN 1973 WRITE(kumout, cform_err) 1974 WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)' 1975 CALL mppstop 1976 ENDIF 1977 1883 1978 ! Look for how many procs with sea-ice 1884 1979 ! … … 1893 1988 1894 1989 ! Allocate the right size to nrank_north 1895 #if ! defined key_agrif1896 1990 IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice ) 1897 #else1898 IF( ASSOCIATED( nrank_ice ) ) DEALLOCATE( nrank_ice )1899 #endif1900 1991 ALLOCATE( nrank_ice(ndim_rank_ice) ) 1901 1992 ! … … 1922 2013 ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 1923 2014 ! 2015 DEALLOCATE(kice, zwork) 2016 ! 1924 2017 END SUBROUTINE mpp_ini_ice 1925 2018 1926 2019 1927 SUBROUTINE mpp_ini_znl 2020 SUBROUTINE mpp_ini_znl( kumout ) 1928 2021 !!---------------------------------------------------------------------- 1929 2022 !! *** routine mpp_ini_znl *** … … 1944 2037 !! 1945 2038 !!---------------------------------------------------------------------- 1946 INTEGER :: ierr 1947 INTEGER :: jproc 1948 INTEGER :: ii 1949 INTEGER, DIMENSION(jpnij) :: kwork 1950 ! 2039 INTEGER, INTENT(in) :: kumout ! ocean.output logical units 2040 ! 2041 INTEGER :: jproc ! dummy loop integer 2042 INTEGER :: ierr, ii ! local integer 2043 INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork 2044 !!---------------------------------------------------------------------- 1951 2045 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world 1952 2046 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 1953 2047 !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa 1954 2048 ! 1955 IF ( jpnj == 1 ) THEN 2049 ALLOCATE( kwork(jpnij), STAT=ierr ) 2050 IF( ierr /= 0 ) THEN 2051 WRITE(kumout, cform_err) 2052 WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 2053 CALL mppstop 2054 ENDIF 2055 2056 IF( jpnj == 1 ) THEN 1956 2057 ngrp_znl = ngrp_world 1957 2058 ncomm_znl = mpi_comm_opa … … 1972 2073 !-$$ CALL flush(numout) 1973 2074 ! Allocate the right size to nrank_znl 1974 #if ! defined key_agrif1975 2075 IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl) 1976 #else1977 IF (ASSOCIATED(nrank_znl)) DEALLOCATE(nrank_znl)1978 #endif1979 2076 ALLOCATE(nrank_znl(ndim_rank_znl)) 1980 2077 ii = 0 … … 2016 2113 END IF 2017 2114 2115 DEALLOCATE(kwork) 2116 2018 2117 END SUBROUTINE mpp_ini_znl 2019 2118 … … 2055 2154 ! 2056 2155 ! Allocate the right size to nrank_north 2057 #if ! defined key_agrif2058 2156 IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north) 2059 #else2060 IF (ASSOCIATED(nrank_north)) DEALLOCATE(nrank_north)2061 #endif2062 2157 ALLOCATE( nrank_north(ndim_rank_north) ) 2063 2158 … … 2106 2201 INTEGER :: ierr, itaille, ildi, ilei, iilb 2107 2202 INTEGER :: ijpj, ijpjm1, ij, iproc 2108 REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab2109 REAL(wp), DIMENSION(jpi ,4,jpk) :: znorthloc2110 REAL(wp), DIMENSION(jpi ,4,jpk,jpni) :: znorthgloio2111 2203 !!---------------------------------------------------------------------- 2112 2204 ! … … 2172 2264 INTEGER :: ierr, itaille, ildi, ilei, iilb 2173 2265 INTEGER :: ijpj, ijpjm1, ij, iproc 2174 REAL(wp), DIMENSION(jpiglo,4) :: ztab2175 REAL(wp), DIMENSION(jpi ,4) :: znorthloc2176 REAL(wp), DIMENSION(jpi ,4,jpni) :: znorthgloio2177 2266 !!---------------------------------------------------------------------- 2178 2267 ! 2179 2268 ijpj = 4 2180 2269 ijpjm1 = 3 2181 ztab (:,:) = 0.e02182 ! 2183 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d2270 ztab_2d(:,:) = 0.e0 2271 ! 2272 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc_2d the last 4 jlines of pt2d 2184 2273 ij = jj - nlcj + ijpj 2185 znorthloc (:,ij) = pt2d(:,jj)2274 znorthloc_2d(:,ij) = pt2d(:,jj) 2186 2275 END DO 2187 2276 2188 ! ! Build in procs of ncomm_north the znorthgloio 2277 ! ! Build in procs of ncomm_north the znorthgloio_2d 2189 2278 itaille = jpi * ijpj 2190 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &2191 & znorthgloio , itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2279 CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, & 2280 & znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2192 2281 ! 2193 2282 DO jr = 1, ndim_rank_north ! recover the global north array … … 2198 2287 DO jj = 1, 4 2199 2288 DO ji = ildi, ilei 2200 ztab (ji+iilb-1,jj) = znorthgloio(ji,jj,jr)2289 ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr) 2201 2290 END DO 2202 2291 END DO 2203 2292 END DO 2204 2293 ! 2205 CALL lbc_nfd( ztab , cd_type, psgn ) ! North fold boundary condition2294 CALL lbc_nfd( ztab_2d, cd_type, psgn ) ! North fold boundary condition 2206 2295 ! 2207 2296 ! … … 2209 2298 ij = jj - nlcj + ijpj 2210 2299 DO ji = 1, nlci 2211 pt2d(ji,jj) = ztab (ji+nimpp-1,ij)2300 pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij) 2212 2301 END DO 2213 2302 END DO … … 2239 2328 INTEGER :: ierr, itaille, ildi, ilei, iilb 2240 2329 INTEGER :: ijpj, ij, iproc 2241 REAL(wp), DIMENSION(jpiglo,4+2*jpr2dj) :: ztab2242 REAL(wp), DIMENSION(jpi ,4+2*jpr2dj) :: znorthloc2243 REAL(wp), DIMENSION(jpi ,4+2*jpr2dj,jpni) :: znorthgloio2244 2330 !!---------------------------------------------------------------------- 2245 2331 ! 2246 2332 ijpj=4 2247 ztab (:,:) = 0.e02333 ztab_e(:,:) = 0.e0 2248 2334 2249 2335 ij=0 2250 ! put in znorthloc the last 4 jlines of pt2d2336 ! put in znorthloc_e the last 4 jlines of pt2d 2251 2337 DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 2252 2338 ij = ij + 1 2253 2339 DO ji = 1, jpi 2254 znorthloc (ji,ij)=pt2d(ji,jj)2340 znorthloc_e(ji,ij)=pt2d(ji,jj) 2255 2341 END DO 2256 2342 END DO 2257 2343 ! 2258 2344 itaille = jpi * ( ijpj + 2 * jpr2dj ) 2259 CALL MPI_ALLGATHER( znorthloc (1,1), itaille, MPI_DOUBLE_PRECISION, &2260 & znorthgloio (1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )2345 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 2346 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2261 2347 ! 2262 2348 DO jr = 1, ndim_rank_north ! recover the global north array … … 2267 2353 DO jj = 1, ijpj+2*jpr2dj 2268 2354 DO ji = ildi, ilei 2269 ztab (ji+iilb-1,jj) = znorthgloio(ji,jj,jr)2355 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 2270 2356 END DO 2271 2357 END DO … … 2275 2361 ! 2. North-Fold boundary conditions 2276 2362 ! ---------------------------------- 2277 CALL lbc_nfd( ztab (:,:), cd_type, psgn, pr2dj = jpr2dj )2363 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj ) 2278 2364 2279 2365 ij = jpr2dj … … 2282 2368 ij = ij +1 2283 2369 DO ji= 1, nlci 2284 pt2d(ji,jj) = ztab (ji+nimpp-1,ij)2370 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 2285 2371 END DO 2286 2372 END DO … … 2335 2421 ! Buffer allocation and attachment 2336 2422 ALLOCATE( tampon(nn_buffer), stat = ierr ) 2337 IF (ierr /= 0) THEN2423 IF( ierr /= 0 ) THEN 2338 2424 DO ji = 1, SIZE(ldtxt) 2339 2425 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode … … 2383 2469 !! Default case: Dummy module share memory computing 2384 2470 !!---------------------------------------------------------------------- 2471 USE in_out_manager 2385 2472 2386 2473 INTERFACE mpp_sum … … 2403 2490 END INTERFACE 2404 2491 2405 2406 2492 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 2407 2493 INTEGER :: ncomm_ice 2408 2494 !!---------------------------------------------------------------------- 2409 2495 CONTAINS 2410 2496 2411 FUNCTION mynode( ldtxt, localComm ) RESULT (function_value) 2412 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 2497 INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function 2498 INTEGER, INTENT(in) :: kumout 2499 lib_mpp_alloc = 0 2500 END FUNCTION lib_mpp_alloc 2501 2502 FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value) 2413 2503 INTEGER, OPTIONAL , INTENT(in ) :: localComm 2504 CHARACTER(len=*),DIMENSION(:) :: ldtxt 2505 INTEGER :: kumnam, kstop 2414 2506 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 2415 2507 IF( .FALSE. ) ldtxt(:) = 'never done' … … 2504 2596 END SUBROUTINE mppmin_int 2505 2597 2506 SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )2507 INTEGER :: kd1, kd2, kl , kk, ktype, kij 2598 SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum ) 2599 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum 2508 2600 REAL, DIMENSION(:) :: parr ! variable array 2509 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij 2601 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum 2510 2602 END SUBROUTINE mppobc_1d 2511 2603 2512 SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )2513 INTEGER :: kd1, kd2, kl , kk, ktype, kij 2604 SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum ) 2605 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum 2514 2606 REAL, DIMENSION(:,:) :: parr ! variable array 2515 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij 2607 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum 2516 2608 END SUBROUTINE mppobc_2d 2517 2609 2518 SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )2519 INTEGER :: kd1, kd2, kl , kk, ktype, kij 2610 SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum ) 2611 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum 2520 2612 REAL, DIMENSION(:,:,:) :: parr ! variable array 2521 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij 2613 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum 2522 2614 END SUBROUTINE mppobc_3d 2523 2615 2524 SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )2525 INTEGER :: kd1, kd2, kl , kk, ktype, kij 2616 SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum ) 2617 INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum 2526 2618 REAL, DIMENSION(:,:,:,:) :: parr ! variable array 2527 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij 2619 WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum 2528 2620 END SUBROUTINE mppobc_4d 2529 2621 … … 2560 2652 END SUBROUTINE mppstop 2561 2653 2562 SUBROUTINE mpp_ini_ice( kcom )2563 INTEGER :: kcom 2564 WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom 2654 SUBROUTINE mpp_ini_ice( kcom, knum ) 2655 INTEGER :: kcom, knum 2656 WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum 2565 2657 END SUBROUTINE mpp_ini_ice 2566 2658 2567 SUBROUTINE mpp_ini_znl 2568 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?' 2659 SUBROUTINE mpp_ini_znl( knum ) 2660 INTEGER :: knum 2661 WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 2569 2662 END SUBROUTINE mpp_ini_znl 2570 2663 … … 2574 2667 END SUBROUTINE mpp_comm_free 2575 2668 #endif 2669 2670 !!---------------------------------------------------------------------- 2671 !! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn routines 2672 !!---------------------------------------------------------------------- 2673 2674 SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , & 2675 & cd6, cd7, cd8, cd9, cd10 ) 2676 !!---------------------------------------------------------------------- 2677 !! *** ROUTINE stop_opa *** 2678 !! 2679 !! ** Purpose : print in ocean.outpput file a error message and 2680 !! increment the error number (nstop) by one. 2681 !!---------------------------------------------------------------------- 2682 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 2683 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 2684 !!---------------------------------------------------------------------- 2685 ! 2686 nstop = nstop + 1 2687 IF(lwp) THEN 2688 WRITE(numout,cform_err) 2689 IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1 2690 IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2 2691 IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3 2692 IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4 2693 IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5 2694 IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6 2695 IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7 2696 IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8 2697 IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9 2698 IF( PRESENT(cd10) ) WRITE(numout,*) cd10 2699 ENDIF 2700 CALL FLUSH(numout ) 2701 IF( numstp /= -1 ) CALL FLUSH(numstp ) 2702 IF( numsol /= -1 ) CALL FLUSH(numsol ) 2703 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 2704 ! 2705 IF( cd1 == 'STOP' ) THEN 2706 IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' 2707 CALL mppstop() 2708 ENDIF 2709 ! 2710 END SUBROUTINE ctl_stop 2711 2712 2713 SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, & 2714 & cd6, cd7, cd8, cd9, cd10 ) 2715 !!---------------------------------------------------------------------- 2716 !! *** ROUTINE stop_warn *** 2717 !! 2718 !! ** Purpose : print in ocean.outpput file a error message and 2719 !! increment the warning number (nwarn) by one. 2720 !!---------------------------------------------------------------------- 2721 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5 2722 CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10 2723 !!---------------------------------------------------------------------- 2724 ! 2725 nwarn = nwarn + 1 2726 IF(lwp) THEN 2727 WRITE(numout,cform_war) 2728 IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1 2729 IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2 2730 IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3 2731 IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4 2732 IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5 2733 IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6 2734 IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7 2735 IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8 2736 IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9 2737 IF( PRESENT(cd10) ) WRITE(numout,*) cd10 2738 ENDIF 2739 CALL FLUSH(numout) 2740 ! 2741 END SUBROUTINE ctl_warn 2742 2743 2744 SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea ) 2745 !!---------------------------------------------------------------------- 2746 !! *** ROUTINE ctl_opn *** 2747 !! 2748 !! ** Purpose : Open file and check if required file is available. 2749 !! 2750 !! ** Method : Fortan open 2751 !!---------------------------------------------------------------------- 2752 INTEGER , INTENT( out) :: knum ! logical unit to open 2753 CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open 2754 CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier 2755 CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier 2756 CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier 2757 INTEGER , INTENT(in ) :: klengh ! record length 2758 INTEGER , INTENT(in ) :: kout ! number of logical units for write 2759 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 2760 INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number 2761 !! 2762 CHARACTER(len=80) :: clfile 2763 INTEGER :: iost 2764 !!---------------------------------------------------------------------- 2765 2766 ! adapt filename 2767 ! ---------------- 2768 clfile = TRIM(cdfile) 2769 IF( PRESENT( karea ) ) THEN 2770 IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1 2771 ENDIF 2772 #if defined key_agrif 2773 IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile) 2774 knum=Agrif_Get_Unit() 2775 #else 2776 knum=get_unit() 2777 #endif 2778 2779 iost=0 2780 IF( cdacce(1:6) == 'DIRECT' ) THEN 2781 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost ) 2782 ELSE 2783 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost ) 2784 ENDIF 2785 IF( iost == 0 ) THEN 2786 IF(ldwp) THEN 2787 WRITE(kout,*) ' file : ', clfile,' open ok' 2788 WRITE(kout,*) ' unit = ', knum 2789 WRITE(kout,*) ' status = ', cdstat 2790 WRITE(kout,*) ' form = ', cdform 2791 WRITE(kout,*) ' access = ', cdacce 2792 WRITE(kout,*) 2793 ENDIF 2794 ENDIF 2795 100 CONTINUE 2796 IF( iost /= 0 ) THEN 2797 IF(ldwp) THEN 2798 WRITE(kout,*) 2799 WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile 2800 WRITE(kout,*) ' ======= === ' 2801 WRITE(kout,*) ' unit = ', knum 2802 WRITE(kout,*) ' status = ', cdstat 2803 WRITE(kout,*) ' form = ', cdform 2804 WRITE(kout,*) ' access = ', cdacce 2805 WRITE(kout,*) ' iostat = ', iost 2806 WRITE(kout,*) ' we stop. verify the file ' 2807 WRITE(kout,*) 2808 ENDIF 2809 STOP 'ctl_opn bad opening' 2810 ENDIF 2811 2812 END SUBROUTINE ctl_opn 2813 2814 2815 INTEGER FUNCTION get_unit() 2816 !!---------------------------------------------------------------------- 2817 !! *** FUNCTION get_unit *** 2818 !! 2819 !! ** Purpose : return the index of an unused logical unit 2820 !!---------------------------------------------------------------------- 2821 LOGICAL :: llopn 2822 !!---------------------------------------------------------------------- 2823 ! 2824 get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO 2825 llopn = .TRUE. 2826 DO WHILE( (get_unit < 998) .AND. llopn ) 2827 get_unit = get_unit + 1 2828 INQUIRE( unit = get_unit, opened = llopn ) 2829 END DO 2830 IF( (get_unit == 999) .AND. llopn ) THEN 2831 CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 2832 get_unit = -1 2833 ENDIF 2834 ! 2835 END FUNCTION get_unit 2836 2576 2837 !!---------------------------------------------------------------------- 2577 2838 END MODULE lib_mpp -
trunk/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r2442 r2715 20 20 PRIVATE 21 21 22 !! * Routine accessibility23 22 PUBLIC mpp_init ! called by opa.F90 24 23 PUBLIC mpp_init2 ! called by opa.F90 … … 29 28 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 30 29 !! $Id$ 31 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 32 !!---------------------------------------------------------------------- 33 30 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 31 !!---------------------------------------------------------------------- 34 32 CONTAINS 35 33 … … 128 126 !! 8.5 ! 02-08 (G. Madec) F90 : free form 129 127 !!---------------------------------------------------------------------- 130 !! * Local variables 131 INTEGER :: ji, jj, jn ! dummy loop indices 132 INTEGER :: & 133 ii, ij, ifreq, il1, il2, & ! temporary integers 134 iresti, irestj, ijm1, imil, & ! " " 135 inum ! temporary logical unit 136 137 INTEGER, DIMENSION(jpni,jpnj) :: & 138 iimppt, ijmppt, ilcit, ilcjt ! temporary workspace 139 REAL(wp) :: zidom, zjdom ! temporary scalars 128 INTEGER :: ji, jj, jn ! dummy loop indices 129 INTEGER :: ii, ij, ifreq, il1, il2 ! local integers 130 INTEGER :: iresti, irestj, ijm1, imil, inum ! - - 131 REAL(wp) :: zidom, zjdom ! local scalars 132 INTEGER, DIMENSION(jpni,jpnj) :: iimppt, ijmppt, ilcit, ilcjt ! local workspace 140 133 !!---------------------------------------------------------------------- 141 134 … … 451 444 !! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij 452 445 !!---------------------------------------------------------------------- 453 !! Local declarations 454 455 INTEGER, DIMENSION(2) :: & 456 iglo, iloc, iabsf, iabsl, ihals, ihale, idid 446 INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 457 447 !!---------------------------------------------------------------------- 458 448 … … 482 472 WRITE(numout,*) ' ihale = ', ihale(1), ihale(2) 483 473 ENDIF 484 474 ! 485 475 CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 486 476 ! 487 477 END SUBROUTINE mpp_init_ioipsl 488 478
Note: See TracChangeset
for help on using the changeset viewer.
