Changeset 2506
- Timestamp:
- 2010-12-23T11:40:44+01:00 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90
r2329 r2506 1 1 MODULE cpl_oasis4 2 2 !!====================================================================== 3 !! *** MODULE cpl_oasis 4***3 !! *** MODULE cpl_oasis *** 4 4 !! Coupled O/A : coupled ocean-atmosphere case using OASIS4 5 !! special case: OPA/LIM coupled to ECHAM56 5 !!===================================================================== 7 6 !! History : … … 11 10 !! " " ! 05-08 (R. Redler, W. Park) frld initialization, paral(2) revision 12 11 !! " " ! 05-09 (R. Redler) extended to allow for communication over root only 13 !! " " ! 05-09 (R. Redler) extended to allow for communication over root only 14 !! " " ! 05-12 (R. Hill, Met. Office) Tweaks and hacks to get NEMO/O4 working 15 !! " " ! 06-02 (R. Redler, W. Park) Bug fixes and updates according to the OASIS3 interface 16 !! " " ! 06-02 (R. Redler) app/grid/grid_name from namelist 12 !! " " ! 06-01 (W. Park) modification of physical part 13 !! " " ! 06-02 (R. Redler, W. Park) buffer array fix for root exchange 14 !! " " ! 2010 (E. Maisonnave and S. Masson) complete rewrite 17 15 !!---------------------------------------------------------------------- 18 16 #if defined key_oasis4 19 17 !!---------------------------------------------------------------------- 20 18 !! 'key_oasis4' coupled Ocean/Atmosphere via OASIS4 19 !!---------------------------------------------------------------------- 21 20 !!---------------------------------------------------------------------- 22 21 !! cpl_prism_init : initialization of coupled mode communication 23 22 !! cpl_prism_define : definition of grid and fields 24 !! cpl_prism_send : send out fields in coupled mode 25 !! cpl_prism_recv : receive fields in coupled mode 23 !! cpl_prism_snd : snd out fields in coupled mode 24 !! cpl_prism_rcv : receive fields in coupled mode 25 !! cpl_prism_update_time : update date sent to Oasis 26 26 !! cpl_prism_finalize : finalize the coupled mode communication 27 27 !!---------------------------------------------------------------------- 28 !! * Modules used 29 !##################### WARNING coupled mode ############################### 30 !##################### WARNING coupled mode ############################### 31 ! Following line must be enabled if coupling with OASIS 32 ! USE prism ! prism module 33 !##################### WARNING coupled mode ############################### 34 !##################### WARNING coupled mode ############################### 35 #if defined key_mpp_mpi 36 USE lib_mpp, only : mppsize, mpprank ! message passing 37 USE lib_mpp, only : mppsend ! message passing 38 USE lib_mpp, only : mpprecv ! message passing 39 #endif 28 USE prism ! OASIS4 prism module 29 USE par_oce ! ocean parameters 40 30 USE dom_oce ! ocean space and time domain 31 USE domwri ! ocean space and time domain 41 32 USE in_out_manager ! I/O manager 42 USE par_oce ! 43 USE phycst, only : rt0 ! freezing point of sea water 44 USE oasis4_date ! OASIS4 date declarations in 45 ! PRISM compatible format 33 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 34 46 35 IMPLICIT NONE 36 PRIVATE 47 37 ! 48 ! Exchange parameters for coupling ORCA-LIM with ECHAM5 49 ! 50 #if defined key_cpl_ocevel 51 INTEGER, PARAMETER :: nsend = 6 52 #else 53 INTEGER, PARAMETER :: nsend = 4 54 #endif 55 56 #if defined key_cpl_discharge 57 INTEGER, PARAMETER :: nrecv = 20 58 #else 59 INTEGER, PARAMETER :: nrecv = 17 60 #endif 61 62 INTEGER, DIMENSION(nsend) :: send_id 63 INTEGER, DIMENSION(nrecv) :: recv_id 64 65 CHARACTER(len=32) :: cpl_send (nsend) 66 CHARACTER(len=32) :: cpl_recv (nrecv) 67 68 CHARACTER(len=16) :: app_name ! application name for OASIS use 69 CHARACTER(len=16) :: comp_name ! name of this PRISM component 70 CHARACTER(len=16) :: grid_name ! name of the grid 71 CHARACTER(len=1) :: c_mpi_send 72 73 ! The following now come in via new module oasis4_date 74 ! TYPE(PRISM_Time_struct), PUBLIC :: dates ! date info for send operation 75 ! TYPE(PRISM_Time_struct), PUBLIC :: dates_bound(2) ! date info for send operation 76 ! TYPE(PRISM_Time_struct), PUBLIC :: dater ! date info for receive operation 77 ! TYPE(PRISM_Time_struct), PUBLIC :: dater_bound(2) ! date info for receive operation 78 ! TYPE(PRISM_Time_struct), PUBLIC :: tmpdate 79 80 PRIVATE 81 82 INTEGER, PARAMETER :: localRoot = 0 83 84 INTEGER :: localRank ! local MPI rank 85 INTEGER :: localSize ! local MPI size 86 INTEGER :: localComm ! local MPI size 87 LOGICAL :: commRank ! true for ranks doing OASIS communication 88 INTEGER :: comp_id ! id returned by prism_init_comp 89 90 INTEGER :: range(5) 91 92 LOGICAL, SAVE :: prism_was_initialized 93 LOGICAL, SAVE :: prism_was_terminated 94 INTEGER, SAVE :: write_grid 95 96 INTEGER :: ierror ! return error code 97 98 #ifdef key_cpl_rootexchg 99 LOGICAL :: rootexchg =.true. ! logical switch 100 #else 101 LOGICAL :: rootexchg =.false. ! logical switch 102 #endif 103 104 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for exchange 105 REAL(wp), DIMENSION(:), ALLOCATABLE :: buffer ! Temporary buffer for exchange 106 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ranges ! Temporary buffer for exchange 107 108 DOUBLE PRECISION :: date_incr 38 ! LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE. ! coupled flag 39 INTEGER :: ncomp_id ! id returned by prism_init_comp 40 INTEGER :: nerror ! return error code 41 INTEGER, PUBLIC :: OASIS_Rcv = 1 ! return code if received field 42 INTEGER, PUBLIC :: OASIS_idle = 0 ! return code if nothing done by oasis 43 44 INTEGER, PARAMETER :: nmaxfld=40 ! Maximum number of coupling fields 45 46 TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information 47 LOGICAL :: laction ! To be coupled or not 48 CHARACTER(len = 8) :: clname ! Name of the coupling field 49 CHARACTER(len = 1) :: clgrid ! Grid type 50 REAL(wp) :: nsgn ! Control of the sign change 51 INTEGER :: nid ! Id of the field 52 END TYPE FLD_CPL 53 54 TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd ! Coupling fields 55 56 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving 57 58 TYPE(PRISM_Time_struct), PUBLIC :: date ! date info for send operation 59 TYPE(PRISM_Time_struct), PUBLIC :: date_bound(2) ! date info for send operation 60 109 61 110 62 !! Routine accessibility 111 63 PUBLIC cpl_prism_init 112 64 PUBLIC cpl_prism_define 113 PUBLIC cpl_prism_send 114 PUBLIC cpl_prism_recv 65 PUBLIC cpl_prism_snd 66 PUBLIC cpl_prism_rcv 67 PUBLIC cpl_prism_update_time 115 68 PUBLIC cpl_prism_finalize 116 69 117 PUBLIC send_id, recv_id 118 119 !!---------------------------------------------------------------------- 120 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 121 !! $Id$ 122 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 70 !!---------------------------------------------------------------------- 71 !! OPA 9.0 , LOCEAN-IPSL (2006) 72 !! $Header$ 73 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 123 74 !!---------------------------------------------------------------------- 124 75 125 76 CONTAINS 126 77 127 SUBROUTINE cpl_prism_init( localCommunicator ) 128 129 IMPLICIT NONE 78 SUBROUTINE cpl_prism_init (kl_comm) 130 79 131 80 !!------------------------------------------------------------------- … … 137 86 !! ** Method : OASIS4 MPI communication 138 87 !!-------------------------------------------------------------------- 139 !! * Arguments 140 !! 141 INTEGER, INTENT(OUT) :: localCommunicator 142 !! 143 !! * Local declarations 144 !! 145 146 NAMELIST/nam_mpp/ app_name, comp_name, c_mpi_send, grid_name 147 148 !! 149 !!-------------------------------------------------------------------- 150 !! 151 IF(lwp) WRITE(numout,*) 152 IF(lwp) WRITE(numout,*) 'cpl_prism_init : initialization in coupled ocean/atmosphere case' 153 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 154 IF(lwp) WRITE(numout,*) 155 156 REWIND( numnam ) 157 READ ( numnam, nam_mpp ) 158 REWIND( numnam ) 159 160 !------------------------------------------------------------------ 161 ! 1st Initialize the PRISM system for the application 162 !------------------------------------------------------------------ 163 164 CALL prism_initialized (prism_was_initialized, ierror) 165 IF ( ierror /= PRISM_Success ) & 166 CALL prism_abort( comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_initialized' ) 167 168 IF ( .NOT. prism_was_initialized ) THEN 169 CALL prism_init( app_name, ierror ) 170 IF ( ierror /= PRISM_Success ) & 171 CALL prism_abort(comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_init') 172 prism_was_initialized = .true. 173 ELSE 174 call prism_abort(comp_id, 'OPA9.0', 'cpl_prism_init: Do not initialize prism twice!') 175 ENDIF 176 ! 177 ! Obtain the actual dates and date bounds 178 ! 179 ! date is determined by adding days since beginning of 180 ! the run to the corresponding initial date. Note that 181 ! OPA internal info about the start date of the experiment 182 ! is bypassed. Instead we rely sololy on the info provided 183 ! by the SCC.xml file. 184 ! 185 dates = PRISM_Jobstart_date 186 187 WRITE(6,*) "PRISM JOB START DATE IS", dates 188 189 ! 190 ! upper bound is determined by adding half a time step 191 ! 192 tmpdate = dates 193 date_incr = rdttra(1)/2.0 194 CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 195 dates_bound(2) = tmpdate 196 ! 197 ! lower bound is determined by half distance to date from previous run 198 ! 199 tmpdate = dates 200 date_incr = ( adatrj - adatrj0 ) * 43200.0 201 CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 202 dates_bound(1) = tmpdate 203 204 dater = dates 205 dater_bound(1) = dates_bound(1) 206 dater_bound(2) = dates_bound(2) 207 208 WRITE(6,*) "DATE send and rec BOUNDS",dater_bound 209 WRITE(6,*) "OTHER BITS FOR DATE",rdttra(1) 210 WRITE(6,*) "adatrj/0",adatrj,adatrj0,date_incr 88 INTEGER, INTENT( OUT ) :: kl_comm ! local communicator of the model 89 ! 90 91 CALL prism_init( 'nemo', nerror ) 211 92 212 93 !------------------------------------------------------------------ 213 94 ! 2nd Initialize the PRISM system for the component 214 95 !------------------------------------------------------------------ 215 216 CALL prism_init_comp ( comp_id, comp_name, ierror ) 217 IF ( ierror /= PRISM_Success ) & 218 CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_init_comp') 219 220 WRITE(6,*) "COMPLETED INIT_COMP",comp_name,comp_id 221 222 !------------------------------------------------------------------ 223 ! 3rd Get an MPI communicator for OPA local communication 224 !------------------------------------------------------------------ 225 226 CALL prism_get_localcomm ( comp_id, localComm, ierror ) 227 IF ( ierror /= PRISM_Success ) & 228 CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_get_localcomm' ) 229 230 localCommunicator = localComm 231 232 WRITE(6,*) "COMPLETED GET_LOCALCOMM",comp_name,comp_id 96 CALL prism_init_comp( ncomp_id, 'oceanx', nerror ) 97 IF( nerror /= PRISM_Success ) CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_init_comp' ) 98 99 !------------------------------------------------------------------ 100 ! 3rd Get an MPI communicator fr OPA local communication 101 !------------------------------------------------------------------ 102 CALL prism_get_localcomm( ncomp_id, kl_comm, nerror ) 103 IF( nerror /= PRISM_Success ) CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_get_localcomm' ) 233 104 234 105 … … 236 107 237 108 238 SUBROUTINE cpl_prism_define () 239 240 IMPLICIT NONE 109 SUBROUTINE cpl_prism_define (krcv, ksnd) 241 110 242 111 !!------------------------------------------------------------------- … … 248 117 !! ** Method : OASIS4 MPI communication 249 118 !!-------------------------------------------------------------------- 250 !! * Arguments 251 !! 252 !! * Local declarations 253 254 INTEGER :: grid_id(2) ! id returned by prism_def_grid 255 256 INTEGER :: upoint_id(2), & 257 vpoint_id(2), & 258 tpoint_id(2), & 259 fpoint_id(2) ! ids returned by prism_set_points 260 261 INTEGER :: umask_id(2), & 262 vmask_id(2), & 263 tmask_id(2), & 264 fmask_id(2) ! ids returned by prism_set_mask 265 266 INTEGER :: grid_type ! PRISM grid type 267 268 INTEGER :: shape(2,3) ! shape of arrays passed to PSMILe 269 INTEGER :: nodim(2) 119 INTEGER, INTENT( IN ) :: krcv, ksnd ! Number of received and sent coupling fields 120 ! 121 INTEGER, DIMENSION(4) :: igrid ! ids returned by prism_def_grid 122 INTEGER, DIMENSION(4) :: iptid ! ids returned by prism_set_points 123 124 INTEGER, DIMENSION(4) :: imskid ! ids returned by prism_set_mask 125 INTEGER, DIMENSION(4) :: iishift ! 126 INTEGER, DIMENSION(4) :: ijshift ! 127 INTEGER, DIMENSION(4) :: iioff ! 128 INTEGER, DIMENSION(4) :: ijoff ! 129 INTEGER, DIMENSION(4) :: itmp ! 130 INTEGER, DIMENSION(1,3) :: iextent ! 131 INTEGER, DIMENSION(1,3) :: ioffset ! 132 133 134 INTEGER :: ishape(2,3) ! shape of arrays passed to PSMILe 270 135 INTEGER :: data_type ! data type of transients 271 136 272 INTEGER :: nbr_corners273 137 274 138 LOGICAL :: new_points 275 139 LOGICAL :: new_mask 276 LOGICAL :: mask(jpi,jpj,jpk) 277 278 INTEGER :: ji, jj, jk ! local loop indicees 279 280 CHARACTER(len=32) :: cpl_send (nsend) 281 CHARACTER(len=32) :: cpl_recv (nrecv) 282 283 CHARACTER(len=32) :: grid_name ! name of the grid 284 CHARACTER(len=32) :: point_name ! name of the grid points 285 286 REAL(kind=wp), ALLOCATABLE :: rclon(:,:,:) 287 REAL(kind=wp), ALLOCATABLE :: rclat(:,:,:) 288 REAL(kind=wp), ALLOCATABLE :: rcz (:,:) 289 140 LOGICAL :: llmask(jpi,jpj,1) 141 142 INTEGER :: ji, jj, jg, jc ! local loop indicees 143 INTEGER :: ii,ij ! index 144 INTEGER, DIMENSION(1) :: ind ! index 145 146 CHARACTER(len=32) :: clpt_name ! name of the grid points 147 CHARACTER(len=7) :: cltxt 148 CHARACTER(len=1), DIMENSION(4) :: clgrd = (/ 'T','U','V','F' /) ! name of the grid points 149 150 REAL(kind=wp), DIMENSION(jpi,jpj,4) :: zclo, zcla 151 REAL(kind=wp), DIMENSION(jpi,jpj ) :: zlon, zlat 152 153 TYPE(PRISM_Time_struct) :: tmpdate 154 INTEGER :: idate_incr ! date increment 155 !! 290 156 !!-------------------------------------------------------------------- 291 157 292 158 IF(lwp) WRITE(numout,*) 293 159 IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case' 294 160 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' 295 161 IF(lwp) WRITE(numout,*) 296 297 ! ----------------------------------------------------------------- 298 ! ... Some initialisation 299 ! ----------------------------------------------------------------- 300 301 send_id = 0 302 recv_id = 0 303 304 #if defined key_mpp_mpi 305 306 ! ----------------------------------------------------------------- 307 ! ... Some MPI stuff relevant for optional exchange via root only 308 ! ----------------------------------------------------------------- 309 310 commRank = .false. 311 312 localRank = mpprank ! from lib_mpp 313 localSize = mppsize ! from lib_mpp 314 315 IF(lwp) WRITE(numout,*) "CALLING DEFINE" 316 317 IF ( rootexchg ) THEN 318 IF ( localRank == localRoot ) commRank = .true. 319 ELSE 320 commRank = .true. 321 ENDIF 322 323 #else 324 ! 325 ! For non-parallel configurations the one and only process ("localRoot") 326 ! takes part in the communication 327 ! 328 localRank = localRoot 329 commRank = .true. 330 331 #endif 332 333 ! ----------------------------------------------------------------- 162 163 ! 334 164 ! ... Allocate memory for data exchange 335 ! ----------------------------------------------------------------- 336 337 338 IF(lwp) WRITE(numout,*) "Abbout to allocate exfld",jpi,jpj 339 340 ALLOCATE(exfld(1:jpi,1:jpj), stat = ierror) 341 IF (ierror > 0) THEN 342 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating Reals') 165 ! 166 ALLOCATE( exfld(nlei-nldi+1, nlej-nldj+1, 1), stat = nerror ) 167 IF ( nerror > 0 ) THEN 168 CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld' ) 343 169 RETURN 344 170 ENDIF 345 171 346 IF ( rootexchg .and. localRank == localRoot ) THEN 347 ALLOCATE(ranges(5,0:localSize-1), stat = ierror) 348 IF (ierror > 0) THEN 349 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating Integer') 350 RETURN 351 ENDIF 352 ENDIF 353 354 !------------------------------------------------------------------ 355 ! 1st Declare the local grid (ORCA tripolar) characteristics for 356 ! surface coupling. The halo regions must be excluded. For 357 ! surface coupling it is sufficient to specify only one 358 ! vertical z-level. 359 !------------------------------------------------------------------ 360 361 grid_type = PRISM_irrlonlat_regvrt 362 363 IF(lwp) WRITE(numout,*) "Set grid type" 364 365 366 ! ----------------------------------------------------------------- 367 ! ... Define the shape of the valid region without the halo. 172 173 ! ----------------------------------------------------------------- 174 ! ... Define the shape of the valid region without the halo and overlaps between cpus 368 175 ! For serial configuration (key_mpp_mpi not being active) 369 176 ! nl* is set to the global values 1 and jp*glo. 370 177 ! ----------------------------------------------------------------- 371 178 372 IF ( rootexchg ) THEN 373 shape(1,1) = 1+jpreci 374 shape(2,1) = jpiglo-jpreci 375 shape(1,2) = 1+jpreci 376 shape(2,2) = jpjglo-jpreci 377 shape(1,3) = 1 378 shape(2,3) = 1 379 ELSE 380 shape(1,1) = 1+jpreci 381 shape(2,1) = jpi-jpreci 382 shape(1,2) = 1+jpreci 383 shape(2,2) = jpj-jpreci 384 shape(1,3) = 1 385 shape(2,3) = 1 386 ENDIF 387 388 IF(lwp) WRITE(numout,*) "commrank is", commRank 389 390 IF ( commRank ) THEN 391 392 IF(lwp) WRITE(numout,*) "CALLING DEF_GRID" 393 394 IF(lwp) WRITE(numout,*) "grid name",grid_name 395 IF(lwp) WRITE(numout,*) " shape",shape 396 IF(lwp) WRITE(numout,*) "grid type",grid_type 397 398 CALL prism_def_grid ( grid_id(1), grid_name, comp_id, shape, & 399 grid_type, ierror ) 400 IF ( ierror /= PRISM_Success ) THEN 401 PRINT *, 'OPA cpl_prism_define: Failure in prism_def_grid' 402 CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_grid') 179 ishape(:,1) = (/ 1, nlei-nldi+1 /) 180 ishape(:,2) = (/ 1, nlej-nldj+1 /) 181 ishape(:,3) = (/ 1, 1 /) 182 183 DO ji = 1, 4 184 CALL prism_def_grid( igrid(ji), 'orca'//clgrd(ji), ncomp_id, ishape, PRISM_irrlonlat_regvrt, nerror ) 185 IF( nerror /= PRISM_Success ) CALL prism_abort (ncomp_id, 'cpl_prism_define', & 186 & 'Failure in prism_def_grid of '//clgrd(jg)//'-point' ) 187 END DO 188 189 ! ----------------------------------------------------------------- 190 ! ... Define the partition 191 ! ----------------------------------------------------------------- 192 193 iextent(1,:) = (/ nlei-nldi+1, nlej-nldj+1, 1 /) 194 ioffset(1,:) = (/ nldi-1+nimpp-1, nldj-1+njmpp-1, 0 /) 195 196 DO ji = 1, 4 197 CALL prism_def_partition( igrid(ji), 1, ioffset, iextent, nerror ) 198 IF( nerror /= PRISM_Success ) CALL prism_abort (ncomp_id, 'cpl_prism_define', & 199 & 'Failure in prism_def_partition of '//clgrd(jg)//'-point' ) 200 END DO 201 202 ! ----------------------------------------------------------------- 203 ! ... Define the elements, i.e. specify the corner points for each 204 ! volume element. In case OPA runs on level coordinates (regular 205 ! in the vertical) we only need to give the 4 horizontal corners 206 ! for a volume element plus the vertical position of the upper 207 ! and lower face. Nevertheless the volume element has 8 corners. 208 ! ----------------------------------------------------------------- 209 210 iioff(:) = (/0,1,0,1/) 211 ijoff(:) = (/0,0,1,1/) 212 iishift(:) = (/0,1,1,0/) 213 ijshift(:) = (/0,0,1,1/) 214 215 DO jg = 1, 4 ! ... the t,u,v,f-points 216 217 cltxt = clgrd(jg)//'-point' 218 219 ! ----------------------------------------------------------------- 220 ! ... Convert OPA masks to logicals and define the masks 221 ! ----------------------------------------------------------------- 222 SELECT CASE( jg ) 223 CASE(1) ; llmask(:,:,1) = ( tmask(:,:,1) ) == 1. 224 CASE(2) ; llmask(:,:,1) = ( umask(:,:,1) ) == 1. 225 CASE(3) ; llmask(:,:,1) = ( vmask(:,:,1) ) == 1. 226 CASE(4) ; llmask(:,:,1) = ( fmask(:,:,1) ) == 1. 227 ! CASE(1) ; llmask(:,:,1) = ( tmask(:,:,1) * dom_uniq('T') ) == 1. 228 ! CASE(2) ; llmask(:,:,1) = ( umask(:,:,1) * dom_uniq('U') ) == 1. 229 ! CASE(3) ; llmask(:,:,1) = ( vmask(:,:,1) * dom_uniq('V') ) == 1. 230 ! CASE(4) ; llmask(:,:,1) = ( fmask(:,:,1) * dom_uniq('F') ) == 1. 231 END SELECT 232 CALL prism_set_mask( imskid(jg), igrid(jg), ishape, llmask(nldi:nlei, nldj:nlej, 1), .TRUE., nerror ) 233 IF( nerror /= PRISM_Success ) CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_mask for '//cltxt ) 234 235 ! ----------------------------------------------------------------- 236 ! ... Define the corners 237 ! ----------------------------------------------------------------- 238 SELECT CASE( jg ) 239 CASE(1) ; zlon(:,:) = glamf(:,:) ; zlat(:,:) = gphif(:,:) 240 CASE(2) ; zlon(:,:) = glamv(:,:) ; zlat(:,:) = gphiv(:,:) 241 CASE(3) ; zlon(:,:) = glamu(:,:) ; zlat(:,:) = gphiu(:,:) 242 CASE(4) ; zlon(:,:) = glamt(:,:) ; zlat(:,:) = gphit(:,:) 243 END SELECT 244 245 DO jc = 1, 4 ! corner number (anti-clockwise, starting from the bottom left corner) 246 DO jj = 2, jpjm1 247 DO ji = 2, jpim1 ! NO vector opt. 248 ii = ji-1 + iioff(jg) + iishift(jc) 249 ij = jj-1 + ijoff(jg) + ijshift(jc) 250 zclo(ji,jj,jc) = zlon(ii,ij) 251 zcla(ji,jj,jc) = zlat(ii,ij) 252 END DO 253 END DO 254 CALL lbc_lnk( zclo(:,:,jc), clgrd(jg), 1. ) ; CALL lbc_lnk( zcla(:,:,jc), clgrd(jg), 1. ) 255 END DO 256 257 CALL prism_set_corners( igrid(jg), 8, ishape, zclo(nldi:nlei, nldj:nlej,:), & 258 & zcla(nldi:nlei, nldj:nlej,:), RESHAPE( (/-1.,1./), (/1,2/) ), nerror ) 259 IF( nerror /= PRISM_Success ) CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_corners of '//cltxt ) 260 261 ! ----------------------------------------------------------------- 262 ! ... Define the center points 263 ! ----------------------------------------------------------------- 264 SELECT CASE( jg ) 265 CASE(1) ; zlon(:,:) = glamt(:,:) ; zlat(:,:) = gphit(:,:) 266 CASE(2) ; zlon(:,:) = glamu(:,:) ; zlat(:,:) = gphiu(:,:) 267 CASE(3) ; zlon(:,:) = glamv(:,:) ; zlat(:,:) = gphiv(:,:) 268 CASE(4) ; zlon(:,:) = glamf(:,:) ; zlat(:,:) = gphif(:,:) 269 END SELECT 270 271 CALL prism_set_points ( iptid(jg), cltxt, igrid(jg), ishape, zlon(nldi:nlei, nldj:nlej), & 272 & zlat(nldi:nlei, nldj:nlej), (/0./), .TRUE., nerror ) 273 IF( nerror /= PRISM_Success ) CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_points '//cltxt ) 274 275 END DO 276 277 ! ... Announce send variables. 278 ! 279 DO ji = 1, ksnd 280 IF ( ssnd(ji)%laction ) THEN 281 282 itmp(:) = 0 283 WHERE( clgrd == ssnd(ji)%clgrid ) itmp = 1 284 ind(:) = maxloc( itmp ) 285 WRITE(6,*) ' grid for field ', ind(1), ssnd(ji)%clname 286 ind(1) = 1 287 288 CALL prism_def_var( ssnd(ji)%nid, ssnd(ji)%clname, igrid(ind(1)), iptid(ind(1)), imskid(ind(1)), (/ 3, 0/), & 289 & ishape, PRISM_Double_Precision, nerror ) 290 IF ( nerror /= PRISM_Success ) CALL prism_abort( ssnd(ji)%nid, 'cpl_prism_define', & 291 & 'Failure in prism_def_var for '//TRIM(ssnd(ji)%clname)) 292 403 293 ENDIF 404 405 !------------------------------------------------------------------ 406 ! 2nd Declare the geometic information for this grid. 407 !------------------------------------------------------------------ 408 409 ! ----------------------------------------------------------------- 410 ! ... Redefine shape which may now include the halo region as well. 411 ! ----------------------------------------------------------------- 412 413 shape(1,1) = 1 414 shape(2,1) = jpi 415 shape(1,2) = 1 416 shape(2,2) = jpj 417 shape(1,3) = 1 418 shape(2,3) = 1 419 420 IF(lwp) WRITE(numout,*) "redefined shape",shape 421 422 ! ----------------------------------------------------------------- 423 ! ... Define the elements, i.e. specify the corner points for each 424 ! volume element. In case OPA runs on level coordinates (regular 425 ! in the vertical) we only need to give the 4 horizontal corners 426 ! for a volume element plus the vertical position of the upper 427 ! and lower face. Nevertheless the volume element has 8 corners. 428 ! ----------------------------------------------------------------- 429 430 ! 431 ! ... Treat corners in the horizontal plane 432 ! 433 ALLOCATE(rclon(shape(1,1):shape(2,1),shape(1,2):shape(2,2),4), & 434 STAT=ierror) 435 IF ( ierror /= 0 ) & 436 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rclon') 437 438 ALLOCATE(rclat(shape(1,1):shape(2,1),shape(1,2):shape(2,2),4), & 439 STAT=ierror) 440 IF ( ierror /= 0 ) & 441 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rclon') 442 443 nbr_corners = 8 444 ! 445 ! ... Set right longitudes and upper latitudes 446 ! 447 DO jj = shape(1,2), shape(2,2) 448 DO ji = shape(1,1), shape(2,1) 449 rclon(ji,jj,1) = glamu(ji,jj) 450 rclon(ji,jj,2) = glamu(ji,jj) 451 rclat(ji,jj,2) = gphiv(ji,jj) 452 rclat(ji,jj,3) = gphiv(ji,jj) 453 ENDDO 454 ENDDO 455 ! 456 ! ... Set the lower latitudes 457 ! 458 DO jj = shape(1,2)+1, shape(2,2) 459 DO ji = shape(1,1), shape(2,1) 460 rclat(ji,jj-1,1) = rclat(ji,jj,2) 461 rclat(ji,jj-1,4) = rclat(ji,jj,3) 462 ENDDO 463 ENDDO 464 ! 465 ! ... Set the left longitudes 466 ! 467 DO jj = shape(1,2), shape(2,2) 468 DO ji = shape(1,1)+1, shape(2,1) 469 rclon(ji-1,jj,3) = rclon(ji,jj,2) 470 rclon(ji-1,jj,4) = rclon(ji,jj,1) 471 ENDDO 472 ENDDO 473 ! 474 ! ... Set the lowermost latitudes 475 ! 476 DO jj = shape(1,2), shape(1,2) 477 DO ji = shape(1,1), shape(2,1) 478 rclat(ji,jj,1) = 2.0*gphit(ji,jj)-rclat(ji,jj,2) 479 rclat(ji,jj,4) = 2.0*gphit(ji,jj)-rclat(ji,jj,4) 480 ENDDO 481 ENDDO 482 ! 483 ! ... Set the rightmost latitudes 484 ! 485 DO jj = shape(1,2), shape(2,2) 486 DO ji = shape(1,2), shape(1,2) 487 rclon(ji,jj,3) = 2.0*glamt(ji,jj)-rclon(ji,jj,2) 488 rclon(ji,jj,4) = 2.0*glamt(ji,jj)-rclon(ji,jj,1) 489 490 WRITE(76,*) "rclon", ji, jj, rclon(ji,jj,1), & 491 rclon(ji,jj,2), & 492 rclon(ji,jj,3), & 493 rclon(ji,jj,4) 494 495 WRITE(76,*) "rclat", ji, jj, rclat(ji,jj,1), & 496 rclat(ji,jj,2), & 497 rclat(ji,jj,3), & 498 rclat(ji,jj,4) 499 500 ENDDO 501 ENDDO 502 503 ! 504 ! ... Treat corners along the vertical axis 505 ! 506 ALLOCATE(rcz(shape(1,3):shape(2,3),2), STAT=ierror) 507 IF ( ierror /= 0 ) & 508 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rcz') 509 510 DO jk = shape(1,3), shape(2,3) 511 rcz(jk,1) = gdepw(jk) 512 rcz(jk,2) = gdepw(jk+1) 513 ENDDO 514 515 IF(lwp) WRITE(numout,*) "ABOUT TO CALL SET CORNERS",shape 516 517 CALL prism_set_corners ( grid_id(1), nbr_corners, shape, rclon, rclat, & 518 rcz, ierror) 519 IF ( ierror /= PRISM_Success ) & 520 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_corners') 521 522 DEALLOCATE(rclon, rclat, rcz) 523 524 ! ----------------------------------------------------------------- 525 ! ... Define the gridpoints 526 ! ----------------------------------------------------------------- 527 528 new_points = .TRUE. 529 530 IF(lwp) WRITE(numout,*) "CALLING SET_POINTS" 531 532 ! 533 ! ... the u-points 534 ! 535 point_name = 'u-points' 536 CALL prism_set_points ( upoint_id(1), point_name, grid_id(1), shape, & 537 glamu, gphiu, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 538 IF ( ierror /= PRISM_Success ) & 539 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points upoint_id') 540 ! 541 ! ... the v-points 542 ! 543 544 IF(lwp) WRITE(numout,*) "CALLING SET_POINTS done u doing v" 545 546 point_name = 'v-points' 547 CALL prism_set_points ( vpoint_id(1), point_name, grid_id(1), shape, & 548 glamv, gphiv, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 549 IF ( ierror /= PRISM_Success ) & 550 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points vpoint_id') 551 ! 552 ! ... the t-points 553 ! 554 ! WRITE(76,*) 'CALLING T POINTS', shape 555 ! WRITE(77,*) 'glamt', glamt 556 ! WRITE(78,*) 'gphit', gphit 557 ! 558 point_name = 't-points' 559 CALL prism_set_points ( tpoint_id(1), point_name, grid_id(1), shape, & 560 glamt, gphit, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 561 IF ( ierror /= PRISM_Success ) & 562 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points tpoint_id') 563 ! 564 ! ... the f-points 565 ! 566 point_name = 'f-points' 567 CALL prism_set_points ( fpoint_id(1), point_name, grid_id(1), shape, & 568 glamf, gphif, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 569 IF ( ierror /= PRISM_Success ) & 570 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points fpoint_id') 571 572 573 IF(lwp) WRITE(numout,*) "CALLING SET_POINTS done f" 574 575 ! ----------------------------------------------------------------- 576 ! ... Convert OPA masks to logicals and define the masks 577 ! ----------------------------------------------------------------- 578 579 new_mask = .true. 580 581 mask = (umask == 1) 582 CALL prism_set_mask (umask_id(1), grid_id(1), shape, & 583 mask(shape(1,1):shape(2,1), & 584 shape(1,2):shape(2,2), & 585 shape(1,3):shape(2,3)), & 586 new_mask, ierror ) 587 IF ( ierror /= PRISM_Success ) & 588 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 589 590 mask = (vmask == 1) 591 CALL prism_set_mask (vmask_id(1), grid_id(1), shape, & 592 mask(shape(1,1):shape(2,1), & 593 shape(1,2):shape(2,2), & 594 shape(1,3):shape(2,3)), & 595 new_mask, ierror ) 596 IF ( ierror /= PRISM_Success ) & 597 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 598 599 mask = (tmask == 1) 600 CALL prism_set_mask (tmask_id(1), grid_id(1), shape, & 601 mask(shape(1,1):shape(2,1), & 602 shape(1,2):shape(2,2), & 603 shape(1,3):shape(2,3)), & 604 new_mask, ierror ) 605 IF ( ierror /= PRISM_Success ) & 606 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 607 608 mask = (fmask == 1) 609 CALL prism_set_mask (fmask_id(1), grid_id(1), shape, & 610 mask(shape(1,1):shape(2,1), & 611 shape(1,2):shape(2,2), & 612 shape(1,3):shape(2,3)), & 613 new_mask, ierror ) 614 IF ( ierror /= PRISM_Success ) & 615 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 616 617 IF(lwp) WRITE(numout,*) "DONE ALL THE SET MASKS" 618 619 ! ----------------------------------------------------------------- 620 ! ... Define the angles 621 ! This is needed if zonal tau is not oriented E-W and meridional 622 ! tau is not oriented along N-S but rather along local coordinate 623 ! axis. Please check!!!! 624 ! ----------------------------------------------------------------- 625 626 !rr cal prism_set_angles ( ..., ierror ) ! not yet supported by OASIS4 627 628 ! ----------------------------------------------------------------- 629 ! ... Define the partition 630 ! ----------------------------------------------------------------- 631 632 IF ( rootexchg ) THEN 633 634 range(1) = nimpp-1+nldi ! global start in i 635 range(2) = nlei-nldi+1 ! local size in i of valid region 636 range(3) = njmpp-1+nldj ! global start in j 637 range(4) = nlej-nldj+1 ! local size in j of valid region 638 range(5) = range(2) & 639 * range(4) ! local horizontal size 640 ! 641 ! Collect ranges from all NEMO procs on the local root process 642 ! 643 CALL mpi_gather(range, 5, MPI_INTEGER, & 644 ranges, 5, MPI_INTEGER, localRoot, localComm, ierror) 645 646 IF ( localRank == localRoot ) THEN 647 648 maxlen = maxval(ranges(5,:)) 649 650 ALLOCATE(buffer(1:maxlen), stat = ierror) 651 IF (ierror > 0) THEN 652 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating buffer') 653 RETURN 654 ENDIF 655 656 ENDIF 294 END DO 295 ! 296 ! ... Announce received variables. 297 ! 298 DO ji = 1, krcv 299 IF ( srcv(ji)%laction ) THEN 300 301 itmp(:) = 0 302 WHERE( clgrd == srcv(ji)%clgrid ) itmp = 1 303 ind(:) = maxloc( itmp ) 304 WRITE(6,*) ' grid for field ', ind(1), srcv(ji)%clname 305 ind(1) = 1 306 307 CALL prism_def_var( srcv(ji)%nid, srcv(ji)%clname, igrid(ind(1)), iptid(ind(1)), imskid(ind(1)), (/ 3, 0/), & 308 & ishape, PRISM_Double_Precision, nerror ) 309 IF ( nerror /= PRISM_Success ) CALL prism_abort( srcv(ji)%nid, 'cpl_prism_define', & 310 & 'Failure in prism_def_var for '//TRIM(srcv(ji)%clname)) 657 311 658 312 ENDIF 659 660 ! ----------------------------------------------------------------- 661 ! ... Define the scalefactors 662 ! ----------------------------------------------------------------- 663 664 !rr WRITE(numout,*) "CALLING SCALEFACTOR" 665 !rr call prism_set_scalefactor ( grid_id(1), shape, e1t, e2t, e3t, ierror ) ! not yet supported by OASIS4 666 !rr WRITE(numout,*) "ABOUT TO DEFINE THE TRANSIENTS" 667 668 !------------------------------------------------------------------ 669 ! 3rd Declare the transient variables 670 !------------------------------------------------------------------ 671 ! 672 ! ... Define symbolic names for the transient fields send by the ocean 673 ! These must be identical to the names specified in the SMIOC file. 674 ! 675 cpl_send( 1)='SOSSTSST' ! sea surface temperature -> sst_io 676 cpl_send( 2)='SITOCEAN' ! sea ice thickness -> hicif (only 1 layer available!) 677 #if defined key_cpl_albedo 678 cpl_send( 3)='STIOCEAN' ! surface temperature over sea ice -> tn_ice 679 cpl_send( 4)='SAIOCEAN' ! albedo over sea ice -> alb_ice 680 #else 681 cpl_send( 3)='SITOCEAN' ! sea ice thickness -> hicif (only 1 layer available!) 682 cpl_send( 4)='SNTOCEAN' ! surface snow thickness over sea ice -> hsnif 683 #endif 684 #if defined key_cpl_ocevel 685 cpl_send( 5)='SUNOCEAN' ! U-velocity -> un 686 cpl_send( 6)='SVNOCEAN' ! V-velocity -> vn 687 #endif 688 ! 689 ! ... Define symbolic names for transient fields received by the ocean. 690 ! These must be identical to the names specified in the SMIOC file. 691 ! 692 ! ... a) U-Grid fields 693 ! 694 cpl_recv( 1)='TXWOCEWU' ! weighted surface downward eastward stress 695 cpl_recv( 2)='TYWOCEWU' ! weighted surface downward northward stress 696 cpl_recv( 3)='TXIOCEWU' ! weighted surface downward eastward stress over ice 697 cpl_recv( 4)='TYIOCEWU' ! weighted surface downward northward stress over ice 698 ! 699 ! ... a) V-Grid fields 700 ! 701 cpl_recv( 5)='TXWOCEWV' ! weighted surface downward eastward stress 702 cpl_recv( 6)='TYWOCEWV' ! weighted surface downward northward stress 703 cpl_recv( 7)='TXIOCEWV' ! weighted surface downward eastward stress over ice 704 cpl_recv( 8)='TYIOCEWV' ! weighted surface downward northward stress over ice 705 ! 706 ! ... a) T-Grid fields 707 ! 708 cpl_recv( 9)='FRWOCEPE' ! P-E over water -> zpew 709 cpl_recv(10)='FRIOCEPE' ! P-E over ice -> zpei 710 cpl_recv(11)='FRROCESN' ! surface downward snow fall -> zpsol 711 cpl_recv(12)='FRIOCEEV' ! surface upward snow flux where sea ice -> zevice 712 713 cpl_recv(13)='QSWOCESR' ! surface net downward shortwave flux -> qsr_oce 714 cpl_recv(14)='QSWOCENS' ! surface downward non-solar heat flux in air -> qnsr_oce 715 cpl_recv(15)='QSIOCESR' ! solar heat flux on sea ice -> qsr_ice 716 cpl_recv(16)='QSIOCENS' ! non-solar heat flux on sea ice -> qnsr_ice 717 cpl_recv(17)='QSIOCEDQ' ! non-solar heat flux derivative -> dqns_ice 718 719 #ifdef key_cpl_discharge 720 cpl_recv(18)='FRWOCEIS' ! ice discharge into ocean -> calving 721 cpl_recv(19)='FRWOCERD' ! river discharge into ocean -> zrunriv 722 cpl_recv(20)='FRWOCECD' ! continental discharge into ocean -> zruncot 723 #endif 724 IF ( wp == 4 ) data_type = PRISM_REAL 725 IF ( wp == 8 ) data_type = PRISM_DOUBLE_PRECISION 726 727 nodim(1) = 3 ! check 728 nodim(2) = 0 729 ! 730 ! ... Announce send variables, all on T points. 731 ! 732 DO ji = 1, nsend 733 ! if ( ji == 2 ) ; then ; nodim(2) = 2 ; else ; nodim(2) = 0 ; endif 734 CALL prism_def_var (send_id(ji), cpl_send(ji), grid_id(1), & 735 tpoint_id(1), tmask_id(1), nodim, shape, data_type, ierror) 736 IF ( ierror /= PRISM_Success ) THEN 737 PRINT *, 'Failed to define transient ', ji, TRIM(cpl_send(ji)) 738 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 739 ENDIF 740 ENDDO 741 ! 742 nodim(1) = 3 ! check 743 nodim(2) = 0 744 ! 745 ! ... Announce recv variables. 746 ! 747 ! ... a) on U points 748 ! 749 DO ji = 1, 4 750 CALL prism_def_var (recv_id(ji), cpl_recv(ji), grid_id(1), & 751 upoint_id(1), umask_id(1), nodim, shape, data_type, ierror) 752 IF ( ierror /= PRISM_Success ) THEN 753 PRINT *, 'Failed to define transient ', ji, TRIM(cpl_recv(ji)) 754 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 755 ENDIF 756 ENDDO 757 ! 758 ! ... b) on V points 759 ! 760 DO ji = 5, 8 761 CALL prism_def_var (recv_id(ji), cpl_recv(ji), grid_id(1), & 762 vpoint_id(1), vmask_id(1), nodim, shape, data_type, ierror) 763 IF ( ierror /= PRISM_Success ) THEN 764 PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) 765 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 766 ENDIF 767 ENDDO 768 ! 769 ! ... c) on T points 770 ! 771 DO ji = 9, nrecv 772 CALL prism_def_var (recv_id(ji), "SORUNOFF", grid_id(1), & 773 tpoint_id(1), tmask_id(1), nodim, shape, data_type, ierror) 774 IF ( ierror /= PRISM_Success ) THEN 775 PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) 776 CALL prism_abort ( comp_id, 'OPA9.0', 'OPA cpl_prism_define: Failure in prism_def_var') 777 ENDIF 778 ENDDO 779 780 ENDIF ! commRank 781 782 !------------------------------------------------------------------ 783 ! 4th End of definition phase 784 !------------------------------------------------------------------ 785 786 IF(lwp) WRITE(numout,*) "ABOUT TO CALL PRISM_ENDDEF" 787 788 CALL prism_enddef(ierror) 789 790 IF(lwp) WRITE(numout,*) "DONE ENDDEF",ierror 791 792 IF ( ierror /= PRISM_Success ) & 793 CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_enddef') 794 795 IF(lwp) WRITE(numout,*) "ALL DONE, EXITING PRISM SET UP PHASE" 796 313 END DO 314 315 !------------------------------------------------------------------ 316 ! End of definition phase 317 !------------------------------------------------------------------ 318 319 CALL prism_enddef( nerror ) 320 IF ( nerror /= PRISM_Success ) CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef') 321 797 322 END SUBROUTINE cpl_prism_define 798 799 800 801 SUBROUTINE cpl_prism_send( var_id, date, data_array, info ) 802 803 IMPLICIT NONE 323 324 325 SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo ) 804 326 805 327 !!--------------------------------------------------------------------- 806 !! *** ROUTINE cpl_prism_s end ***328 !! *** ROUTINE cpl_prism_snd *** 807 329 !! 808 330 !! ** Purpose : - At each coupling time-step,this routine sends fields 809 331 !! like sst or ice cover to the coupler or remote application. 810 !!811 !! ** Method : OASIS4812 332 !!---------------------------------------------------------------------- 813 333 !! * Arguments 814 334 !! 815 INTEGER, INTENT( IN ) :: var_id ! variable Id 816 INTEGER, INTENT( OUT ) :: info ! variable Id 817 INTEGER, INTENT( IN ) :: date ! ocean time-step in seconds 818 REAL(wp) :: data_array(:,:) 819 !! 820 !! * Local declarations 821 !! 822 #if defined key_mpp_mpi 823 REAL(wp) :: global_array(jpiglo,jpjglo) 824 ! 825 !mpi INTEGER :: status(MPI_STATUS_SIZE) 826 !mpi INTEGER :: type ! MPI data type 827 INTEGER :: request ! MPI isend request 828 INTEGER :: ji, jj, jn ! local loop indicees 829 #else 830 INTEGER :: ji 831 #endif 832 !! 833 INTEGER, SAVE :: ncount = 0 335 INTEGER, INTENT( IN ) :: kid ! variable intex in the array 336 INTEGER, INTENT( OUT ) :: kinfo ! OASIS4 info argument 337 INTEGER, INTENT( IN ) :: kstep ! ocean time-step in seconds 338 REAL(wp), DIMENSION(jpi,jpj), INTENT( IN ) :: pdata 339 !! 834 340 !! 835 341 !!-------------------------------------------------------------------- 836 !! 837 ncount = ncount + 1 838 839 #if defined key_mpp_mpi 840 841 request = 0 842 843 IF ( rootexchg ) THEN 844 ! 845 !mpi IF ( wp == 4 ) type = MPI_REAL 846 !mpi IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION 847 ! 848 ! collect data on the local root process 849 ! 850 IF ( localRank /= localRoot ) THEN 851 852 DO jj = nldj, nlej 853 DO ji = nldi, nlei 854 exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) 855 ENDDO 856 ENDDO 857 858 !mpi CALL mpi_send(exfld, range(5), type, localRoot, localRank, localComm, ierror) 859 CALL mppsend (localRank, exfld, range(5), localRoot, request) 860 ENDIF 861 862 IF ( localRank == localRoot ) THEN 863 864 DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 865 DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 866 global_array(ji,jj) = data_array(ji,jj) ! workaround 867 ENDDO 868 ENDDO 869 870 DO jn = 1, localSize-1 871 872 !mpi CALL mpi_recv(buffer, ranges(5,jn), type, localRoot, jn, localComm, status, ierror) 873 CALL mpprecv(jn, buffer, ranges(5,jn)) 874 875 DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 876 DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 877 global_array(ji,jj) = buffer( (jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1 ) 878 ENDDO 879 ENDDO 880 881 ENDDO 882 883 ENDIF 884 ! 885 ! send data from local root to OASIS4 886 ! 887 CALL prism_put ( var_id, dates, dates_bound, global_array, info, ierror ) 888 889 ELSE 890 ! 891 ! send local data from every process to OASIS4 892 ! 893 CALL prism_put ( var_id, dates, dates_bound, data_array, info, ierror ) 894 895 ENDIF !rootexchg 896 897 #else 898 899 ! 900 ! send local data from every process to OASIS4 901 ! 902 IF ( commRank ) & 903 CALL prism_put ( var_id, dates, dates_bound, data_array, info, ierror ) 904 905 #endif 906 907 IF ( commRank ) THEN 908 909 IF (l_ctl) THEN 910 911 IF ( info==PRISM_Cpl ) THEN 912 WRITE(numout,*) '****************' 913 DO ji = 1, nsend 914 IF (var_id == send_id(ji) ) THEN 915 WRITE(numout,*) 'prism_put_proto: Outgoing ', cpl_send(ji) 916 EXIT 917 ENDIF 918 ENDDO 919 WRITE(numout,*) 'prism_put: var_id ', var_id 920 WRITE(numout,*) 'prism_put: date ', date 921 WRITE(numout,*) 'prism_put: info ', info 922 WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) 923 WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) 924 WRITE(numout,*) ' - Sum value is ', SUM(data_array) 925 WRITE(numout,*) '****************' 926 ENDIF 927 928 ENDIF 929 930 IF ( ncount == nrecv ) THEN 931 ! 932 ! 3. Update dates and dates_bound for next step. We assume that cpl_prism_send 933 ! is called for all send fields at each time step. Therefore we update 934 ! the date argument to prism_put only every nsend call to cpl_prism_send. 935 ! 936 dates_bound(1) = dates_bound(2) 937 938 tmpdate = dates_bound(2) 939 date_incr = rdCplttra(1)/2.0 940 941 CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 942 dates = tmpdate 943 CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 944 dates_bound(2) = tmpdate 945 946 ncount = 0 947 948 ENDIF 949 950 ENDIF ! commRank 951 952 END SUBROUTINE cpl_prism_send 953 954 955 956 SUBROUTINE cpl_prism_recv( var_id, date, data_array, info ) 957 958 IMPLICIT NONE 342 ! 343 ! snd data to OASIS4 344 ! 345 exfld(:,:,1) = pdata(nldi:nlei, nldj:nlej) 346 CALL prism_put( ssnd(kid)%nid, date, date_bound, exfld, kinfo, nerror ) 347 IF ( nerror /= PRISM_Success ) CALL prism_abort( ssnd(kid)%nid, 'cpl_prism_snd', & 348 & 'Failure in prism_put for '//TRIM(ssnd(kid)%clname) ) 349 350 IF ( ln_ctl ) THEN 351 IF ( kinfo >= PRISM_Cpl .OR. kinfo == PRISM_Rst .OR. & 352 & kinfo == PRISM_RstTimeop ) THEN 353 WRITE(numout,*) '****************' 354 WRITE(numout,*) 'prism_put: Outgoing ', ssnd(kid)%clname 355 WRITE(numout,*) 'prism_put: ivarid ', ssnd(kid)%nid 356 WRITE(numout,*) 'prism_put: kstep ', kstep 357 WRITE(numout,*) 'prism_put: info ', kinfo 358 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata) 359 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata) 360 WRITE(numout,*) ' - Sum value is ', SUM(pdata) 361 WRITE(numout,*) '****************' 362 ENDIF 363 ENDIF 364 END SUBROUTINE cpl_prism_snd 365 366 367 SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo ) 959 368 960 369 !!--------------------------------------------------------------------- 961 !! *** ROUTINE cpl_prism_r ecv ***370 !! *** ROUTINE cpl_prism_rcv *** 962 371 !! 963 372 !! ** Purpose : - At each coupling time-step,this routine receives fields 964 373 !! like stresses and fluxes from the coupler or remote application. 965 !!966 !! ** Method : OASIS4967 374 !!---------------------------------------------------------------------- 968 !! * Arguments 969 !! 970 INTEGER, INTENT( IN ) :: var_id ! variable Id 971 INTEGER, INTENT( OUT ) :: info ! variable Id 972 INTEGER, INTENT( IN ) :: date ! ocean time-step in seconds 973 REAL(wp),INTENT( OUT ) :: data_array(:,:) 974 !! 975 !! * Local declarations 976 !! 977 #if defined key_mpp_mpi 978 REAL(wp) :: global_array(jpiglo,jpjglo) 979 ! 980 LOGICAL :: action = .false. 981 !mpi INTEGER :: status(MPI_STATUS_SIZE) 982 !mpi INTEGER :: type ! MPI data type 983 INTEGER :: request ! MPI isend request 984 INTEGER :: ji, jj, jn ! local loop indicees 985 #else 986 INTEGER :: ji 987 #endif 988 989 INTEGER, SAVE :: ncount = 0 990 !! 375 INTEGER, INTENT( IN ) :: kid ! variable intex in the array 376 INTEGER, INTENT( IN ) :: kstep ! ocean time-step in seconds 377 REAL(wp), DIMENSION(jpi,jpj), INTENT( INOUT ) :: pdata ! IN to keep the value if nothing is done 378 INTEGER, INTENT( OUT ) :: kinfo ! OASIS4 info argument 379 !! 380 LOGICAL :: llaction 991 381 !!-------------------------------------------------------------------- 992 !! 993 ncount = ncount + 1 994 995 #ifdef key_mpp_mpi 996 997 request = 0 998 999 IF ( rootexchg ) THEN 1000 ! 1001 ! receive data from OASIS4 on local root 1002 ! 1003 IF ( commRank ) & 1004 CALL prism_get (var_id, dater, dater_bound, global_array, info, ierror) 1005 CALL MPI_BCAST ( info, 1, MPI_INTEGER, localRoot, localComm, ierror ) 1006 1007 ELSE 1008 ! 1009 ! receive local data from OASIS4 on every process 1010 ! 1011 CALL prism_get (var_id, dater, dater_bound, exfld, info, ierror) 1012 1013 ENDIF 1014 1015 action = (info==PRISM_CplIO) 1016 1017 IF ( rootexchg .and. action ) THEN 1018 ! 1019 !mpi IF ( wp == 4 ) type = MPI_REAL 1020 !mpi IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION 1021 ! 1022 ! distribute data to processes 1023 ! 1024 IF ( localRank == localRoot ) THEN 1025 1026 DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 1027 DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 1028 exfld(ji,jj) = global_array(ji,jj) 1029 ENDDO 1030 ENDDO 1031 1032 DO jn = 1, localSize-1 1033 1034 DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 1035 DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 1036 buffer( (jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1 ) = global_array(ji,jj) 1037 ENDDO 1038 ENDDO 1039 1040 !mpi CALL mpi_send(buffer, ranges(5,jn), type, jn, jn, localComm, ierror) 1041 CALL mppsend (jn, buffer, ranges(5,jn), jn, request) 1042 1043 ENDDO 1044 1045 ENDIF 1046 1047 IF ( localRank /= localRoot ) & 1048 !mpi CALL mpi_recv(exfld, range(5), type, localRoot, localRank, localComm, status, ierror) 1049 CALL mpprecv(localRank, exfld, range(5)) 1050 ENDIF 1051 1052 IF ( action ) THEN 1053 1054 data_array = 0.0 1055 1056 DO jj = nldj, nlej 1057 DO ji = nldi, nlei 1058 data_array(ji,jj)=exfld(ji-nldi+1,jj-nldj+1) 1059 ENDDO 1060 ENDDO 1061 1062 IF (l_ctl) THEN 382 ! 383 ! receive local data from OASIS4 on every process 384 ! 385 CALL prism_get( srcv(kid)%nid, date, date_bound, exfld, kinfo, nerror ) 386 IF ( nerror /= PRISM_Success ) CALL prism_abort( srcv(kid)%nid, 'cpl_prism_rcv', & 387 & 'Failure in prism_get for '//TRIM(srcv(kid)%clname) ) 388 389 WRITE(numout,*) 'prism_get: Incoming ', srcv(kid)%clname 390 call flush(numout) 391 llaction = .false. 392 IF( kinfo == PRISM_Cpl ) llaction = .TRUE. 393 394 IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid 395 396 IF ( llaction ) THEN 397 398 kinfo = OASIS_Rcv 399 pdata(nldi:nlei, nldj:nlej) = exfld(:,:,1) 400 401 !--- Fill the overlap areas and extra hallows (mpp) 402 !--- check periodicity conditions (all cases) 403 CALL lbc_lnk( pdata, srcv(kid)%clgrid, srcv(kid)%nsgn ) 404 405 IF ( ln_ctl ) THEN 1063 406 WRITE(numout,*) '****************' 1064 DO ji = 1, nrecv 1065 IF (var_id == recv_id(ji) ) THEN 1066 WRITE(numout,*) 'prism_get: Incoming ', cpl_recv(ji) 1067 EXIT 1068 ENDIF 1069 ENDDO 1070 WRITE(numout,*) 'prism_get: var_id ', var_id 1071 WRITE(numout,*) 'prism_get: date ', date 1072 WRITE(numout,*) 'prism_get: info ', info 1073 WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) 1074 WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) 1075 WRITE(numout,*) ' - Sum value is ', SUM(data_array) 407 WRITE(numout,*) 'prism_get: Incoming ', srcv(kid)%clname 408 WRITE(numout,*) 'prism_get: ivarid ' , srcv(kid)%nid 409 WRITE(numout,*) 'prism_get: kstep', kstep 410 WRITE(numout,*) 'prism_get: info ', kinfo 411 WRITE(numout,*) ' - Minimum value is ', MINVAL(pdata) 412 WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata) 413 WRITE(numout,*) ' - Sum value is ', SUM(pdata) 1076 414 WRITE(numout,*) '****************' 1077 415 ENDIF 1078 416 417 ELSE 418 kinfo = OASIS_idle 1079 419 ENDIF 1080 #else 1081 1082 CALL prism_get (var_id, dater, dater_bound, exfld, info, ierror) 1083 1084 IF ( info==PRISM_CplIO ) THEN 1085 data_array=exfld 1086 1087 IF (l_ctl) THEN 1088 WRITE(numout,*) '****************' 1089 DO ji = 1, nrecv 1090 IF (var_id == recv_id(ji) ) THEN 1091 WRITE(numout,*) 'prism_get: Incoming ', cpl_recv(ji) 1092 EXIT 1093 ENDIF 1094 ENDDO 1095 WRITE(numout,*) 'prism_get: var_id ', var_id 1096 WRITE(numout,*) 'prism_get: date ', date 1097 WRITE(numout,*) 'prism_get: info ', info 1098 WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) 1099 WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) 1100 WRITE(numout,*) ' - Sum value is ', SUM(data_array) 1101 WRITE(numout,*) '****************' 1102 ENDIF 1103 1104 ENDIF 1105 1106 #endif 1107 1108 IF ( ncount == nrecv ) THEN 1109 ! 1110 ! 3. Update dater and dater_bound for next step. We assume that cpl_prism_recv 1111 ! is called for all recv fields at each time step. Therefore we update 1112 ! the date argument to prism_get only every nrecv call to cpl_prism_recv. 1113 ! 1114 dater_bound(1) = dater_bound(2) 1115 1116 tmpdate = dater_bound(2) 1117 date_incr = rdttra(1)/2.0 1118 1119 CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 1120 dater = tmpdate 1121 CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 1122 dater_bound(2) = tmpdate 1123 1124 ncount = 0 1125 1126 ENDIF 1127 1128 END SUBROUTINE cpl_prism_recv 1129 420 421 422 END SUBROUTINE cpl_prism_rcv 1130 423 1131 424 1132 425 SUBROUTINE cpl_prism_finalize 1133 1134 IMPLICIT NONE1135 426 1136 427 !!--------------------------------------------------------------------- … … 1140 431 !! called explicitly before cpl_prism_init it will also close 1141 432 !! MPI communication. 1142 !!1143 !! ** Method : OASIS41144 433 !!---------------------------------------------------------------------- 1145 434 1146 435 DEALLOCATE(exfld) 1147 1148 if ( prism_was_initialized ) then 1149 1150 call prism_terminated ( prism_was_terminated, ierror ) 1151 1152 if ( prism_was_terminated ) then 1153 print *, 'prism has already been terminated.' 1154 else 1155 call prism_terminate ( ierror ) 1156 prism_was_terminated = .true. 1157 endif 1158 1159 else 1160 1161 print *, 'Initialize prism before terminating it.' 1162 1163 endif 1164 436 CALL prism_terminate ( nerror ) 1165 437 1166 438 END SUBROUTINE cpl_prism_finalize 1167 439 1168 #else 1169 1170 !!---------------------------------------------------------------------- 1171 !! Default case Dummy module forced Ocean/Atmosphere 1172 !!---------------------------------------------------------------------- 1173 CONTAINS 1174 SUBROUTINE cpl_prism_init ! Dummy routine 1175 END SUBROUTINE cpl_prism_init 1176 SUBROUTINE cpl_prism_define ! Dummy routine 1177 END SUBROUTINE cpl_prism_define 1178 SUBROUTINE cpl_prism_send ! Dummy routine 1179 END SUBROUTINE cpl_prism_send 1180 SUBROUTINE cpl_prism_recv ! Dummy routine 1181 END SUBROUTINE cpl_prism_recv 1182 SUBROUTINE cpl_prism_finalize ! Dummy routine 1183 END SUBROUTINE cpl_prism_finalize 440 SUBROUTINE cpl_prism_update_time(kt) 441 442 !!--------------------------------------------------------------------- 443 !! *** ROUTINE cpl_prism_update_time *** 444 !! 445 !! ** Purpose : - Increment date with model timestep 446 !! called explicitly at the end of each timestep 447 !!---------------------------------------------------------------------- 448 449 INTEGER, INTENT(in) :: kt ! ocean model time step index 450 451 TYPE(PRISM_Time_struct) :: tmpdate 452 INTEGER :: idate_incr ! date increment 453 454 455 IF( kt == nit000 ) THEN 456 ! 457 ! Define the actual date 458 ! 459 ! date is determined by adding days since beginning of the run to the corresponding initial date. 460 ! Note that OPA internal info about the start date of the experiment is bypassed. 461 ! Instead we rely sololy on the info provided by the SCC.xml file. 462 ! 463 date = PRISM_Jobstart_date 464 ! 465 ! 466 ! lower/upper bound is determined by adding half a time step 467 ! 468 idate_incr = 0.5 * NINT ( rdttra(1) ) 469 tmpdate = date ; CALL PRISM_calc_newdate ( tmpdate, -idate_incr, nerror ) ; date_bound(1) = tmpdate 470 tmpdate = date ; CALL PRISM_calc_newdate ( tmpdate, idate_incr, nerror ) ; date_bound(2) = tmpdate 471 472 ELSE 473 ! 474 ! Date update 475 ! 476 idate_incr = rdttra(1) 477 CALL PRISM_calc_newdate( date, idate_incr, nerror ) 478 date_bound(1) = date_bound(2) 479 tmpdate = date_bound(2) 480 CALL PRISM_calc_newdate( tmpdate, idate_incr, nerror ) 481 date_bound(2) = tmpdate 482 483 END IF 484 485 END SUBROUTINE cpl_prism_update_time 1184 486 1185 487 #endif
Note: See TracChangeset
for help on using the changeset viewer.