1 | MODULE cpl_oasis3 |
---|
2 | !!====================================================================== |
---|
3 | !! *** MODULE cpl_oasis *** |
---|
4 | !! Coupled O/A : coupled ocean-atmosphere case using OASIS3 V. prism_2_4 |
---|
5 | !! special case: NEMO OPA/LIM coupled to ECHAM5 |
---|
6 | !!===================================================================== |
---|
7 | !! History : |
---|
8 | !! 9.0 ! 04-06 (R. Redler, NEC CCRLE, Germany) Original code |
---|
9 | !! " " ! 04-11 (R. Redler, N. Keenlyside) revision |
---|
10 | !! " " ! 04-11 (V. Gayler, MPI M&D) Grid writing |
---|
11 | !! " " ! 05-08 (R. Redler, W. Park) frld initialization, paral(2) revision |
---|
12 | !! " " ! 05-09 (R. Redler) extended to allow for communication over root only |
---|
13 | !! " " ! 06-01 (W. Park) modification of physical part |
---|
14 | !! " " ! 06-02 (R. Redler, W. Park) buffer array fix for root exchange |
---|
15 | !!---------------------------------------------------------------------- |
---|
16 | #if defined key_oasis3 |
---|
17 | !!---------------------------------------------------------------------- |
---|
18 | !! 'key_oasis3' coupled Ocean/Atmosphere via OASIS3 |
---|
19 | !!---------------------------------------------------------------------- |
---|
20 | !!---------------------------------------------------------------------- |
---|
21 | !! cpl_prism_init : initialization of coupled mode communication |
---|
22 | !! cpl_prism_define : definition of grid and fields |
---|
23 | !! cpl_prism_send : send out fields in coupled mode |
---|
24 | !! cpl_prism_recv : receive fields in coupled mode |
---|
25 | !! cpl_prism_finalize : finalize the coupled mode communication |
---|
26 | !!---------------------------------------------------------------------- |
---|
27 | !! * Modules used |
---|
28 | !##################### WARNING coupled mode ############################### |
---|
29 | !##################### WARNING coupled mode ############################### |
---|
30 | ! Following lines must be enabled if coupling with OASIS |
---|
31 | ! |
---|
32 | ! USE mod_prism_proto ! OASIS3 prism module |
---|
33 | ! USE mod_prism_def_partition_proto! OASIS3 prism module for partitioning |
---|
34 | ! USE mod_prism_grids_writing ! OASIS3 prism module for writing grid files |
---|
35 | ! USE mod_prism_put_proto ! OASIS3 prism module for sending |
---|
36 | ! USE mod_prism_get_proto ! OASIS3 prism module for receiving |
---|
37 | ! USE mod_prism_grids_writing ! OASIS3 prism module for writing grids |
---|
38 | !##################### WARNING coupled mode ############################### |
---|
39 | !##################### WARNING coupled mode ############################### |
---|
40 | #if defined key_mpp_mpi |
---|
41 | USE lib_mpp, only : mppsize, mpprank ! message passing |
---|
42 | USE lib_mpp, only : mppsend ! message passing |
---|
43 | USE lib_mpp, only : mpprecv ! message passing |
---|
44 | #endif |
---|
45 | USE daymod ! date and time info |
---|
46 | USE dom_oce ! ocean space and time domain |
---|
47 | USE in_out_manager ! I/O manager |
---|
48 | USE par_oce ! |
---|
49 | USE phycst, only : rt0 ! freezing point of sea water |
---|
50 | |
---|
51 | USE oce, only: tn, un, vn |
---|
52 | USE ice, only: frld, hicif, hsnif |
---|
53 | USE flx_oce, only : alb_ice , & ! albedo of ice |
---|
54 | tn_ice ! ice surface temperature |
---|
55 | |
---|
56 | IMPLICIT NONE |
---|
57 | ! |
---|
58 | ! Exchange parameters for coupling ORCA-LIM with ECHAM5 |
---|
59 | ! |
---|
60 | #if defined key_cpl_ocevel |
---|
61 | INTEGER, PARAMETER :: nsend = 6 |
---|
62 | #else |
---|
63 | INTEGER, PARAMETER :: nsend = 4 |
---|
64 | #endif |
---|
65 | |
---|
66 | #if defined key_cpl_discharge |
---|
67 | INTEGER, PARAMETER :: nrecv = 20 |
---|
68 | #else |
---|
69 | INTEGER, PARAMETER :: nrecv = 17 |
---|
70 | #endif |
---|
71 | |
---|
72 | INTEGER, DIMENSION(nsend) :: send_id |
---|
73 | INTEGER, DIMENSION(nrecv) :: recv_id |
---|
74 | |
---|
75 | CHARACTER(len=32) :: cpl_send (nsend) |
---|
76 | CHARACTER(len=32) :: cpl_recv (nrecv) |
---|
77 | |
---|
78 | PRIVATE |
---|
79 | |
---|
80 | INTEGER :: localRank ! local MPI rank |
---|
81 | INTEGER :: comp_id ! id returned by prism_init_comp |
---|
82 | |
---|
83 | INTEGER :: range(5) |
---|
84 | |
---|
85 | INTEGER, PARAMETER :: localRoot = 0 |
---|
86 | INTEGER :: localSize ! local MPI size |
---|
87 | INTEGER :: localComm ! local MPI size |
---|
88 | LOGICAL :: commRank ! true for ranks doing OASIS communication |
---|
89 | |
---|
90 | LOGICAL, SAVE :: prism_was_initialized |
---|
91 | LOGICAL, SAVE :: prism_was_terminated |
---|
92 | INTEGER, SAVE :: write_grid |
---|
93 | |
---|
94 | INTEGER :: ierror ! return error code |
---|
95 | |
---|
96 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving |
---|
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 :: buffer ! Temporary buffer for exchange |
---|
105 | INTEGER, DIMENSION(:,:), ALLOCATABLE :: ranges ! Temporary buffer for exchange |
---|
106 | |
---|
107 | !! Routine accessibility |
---|
108 | PUBLIC cpl_prism_init |
---|
109 | PUBLIC cpl_prism_define |
---|
110 | PUBLIC cpl_prism_send |
---|
111 | PUBLIC cpl_prism_recv |
---|
112 | PUBLIC cpl_prism_finalize |
---|
113 | |
---|
114 | PUBLIC send_id, recv_id |
---|
115 | |
---|
116 | !!---------------------------------------------------------------------- |
---|
117 | !! OPA 9.0 , LOCEAN-IPSL (2006) |
---|
118 | !! $Header$ |
---|
119 | !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) |
---|
120 | !!---------------------------------------------------------------------- |
---|
121 | |
---|
122 | CONTAINS |
---|
123 | |
---|
124 | SUBROUTINE cpl_prism_init( localCommunicator ) |
---|
125 | |
---|
126 | IMPLICIT NONE |
---|
127 | |
---|
128 | !!------------------------------------------------------------------- |
---|
129 | !! *** ROUTINE cpl_prism_init *** |
---|
130 | !! |
---|
131 | !! ** Purpose : Initialize coupled mode communication for ocean |
---|
132 | !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) |
---|
133 | !! |
---|
134 | !! ** Method : OASIS3 MPI communication |
---|
135 | !!-------------------------------------------------------------------- |
---|
136 | !! * Arguments |
---|
137 | !! |
---|
138 | INTEGER, INTENT(OUT) :: localCommunicator |
---|
139 | !! |
---|
140 | !! * Local declarations |
---|
141 | !! |
---|
142 | CHARACTER(len=4) :: comp_name ! name of this PRISM component |
---|
143 | !! |
---|
144 | !!-------------------------------------------------------------------- |
---|
145 | !! |
---|
146 | IF(lwp) WRITE(numout,*) |
---|
147 | IF(lwp) WRITE(numout,*) 'cpl_prism_init : initialization in coupled ocean/atmosphere case' |
---|
148 | IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' |
---|
149 | IF(lwp) WRITE(numout,*) |
---|
150 | |
---|
151 | #if defined key_flx_bulk_monthly || defined key_flx_bulk_daily || defined key_flx_forced_daily |
---|
152 | IF(lwp)WRITE(numout,cform_err) |
---|
153 | IF(lwp)WRITE(numout,*) ' key_coupled and key_flx_bulk_* key_flx_forced_daily are incompatible' |
---|
154 | nstop = nstop + 1 |
---|
155 | #endif |
---|
156 | |
---|
157 | comp_name = 'opa9' |
---|
158 | |
---|
159 | !------------------------------------------------------------------ |
---|
160 | ! 1st Initialize the PRISM system for the application |
---|
161 | !------------------------------------------------------------------ |
---|
162 | |
---|
163 | CALL prism_init_comp_proto ( comp_id, comp_name, ierror ) |
---|
164 | IF ( ierror /= PRISM_Ok ) & |
---|
165 | CALL prism_abort_proto (comp_id, 'cpl_prism_init', 'Failure in prism_init_comp_proto') |
---|
166 | prism_was_initialized = .true. |
---|
167 | |
---|
168 | !------------------------------------------------------------------ |
---|
169 | ! 3rd Get an MPI communicator for OPA local communication |
---|
170 | !------------------------------------------------------------------ |
---|
171 | |
---|
172 | CALL prism_get_localcomm_proto ( localComm, ierror ) |
---|
173 | IF ( ierror /= PRISM_Ok ) & |
---|
174 | CALL prism_abort_proto (comp_id, 'cpl_prism_init','Failure in prism_get_localcomm_proto' ) |
---|
175 | |
---|
176 | localCommunicator = localComm |
---|
177 | |
---|
178 | END SUBROUTINE cpl_prism_init |
---|
179 | |
---|
180 | |
---|
181 | SUBROUTINE cpl_prism_define () |
---|
182 | |
---|
183 | IMPLICIT NONE |
---|
184 | |
---|
185 | !!------------------------------------------------------------------- |
---|
186 | !! *** ROUTINE cpl_prism_define *** |
---|
187 | !! |
---|
188 | !! ** Purpose : Define grid and field information for ocean |
---|
189 | !! exchange between AGCM, OGCM and COUPLER. (OASIS3 software) |
---|
190 | !! |
---|
191 | !! ** Method : OASIS3 MPI communication |
---|
192 | !!-------------------------------------------------------------------- |
---|
193 | !! * Arguments |
---|
194 | !! |
---|
195 | !! * Local declarations |
---|
196 | !! |
---|
197 | INTEGER :: grid_id(2) ! id returned by prism_def_grid |
---|
198 | INTEGER :: part_id |
---|
199 | |
---|
200 | INTEGER :: paral(5) ! OASIS3 box partition |
---|
201 | |
---|
202 | INTEGER :: shape(2,3) ! shape of arrays passed to PSMILe |
---|
203 | INTEGER :: nodim(2) |
---|
204 | INTEGER :: data_type ! data type of transients |
---|
205 | |
---|
206 | INTEGER :: ji, jj ! local loop indicees |
---|
207 | INTEGER :: nx, ny, nc ! local variables |
---|
208 | INTEGER :: im1, ip1 |
---|
209 | INTEGER :: jm1, jp1 |
---|
210 | INTEGER :: i_grid ! loop index |
---|
211 | INTEGER :: info |
---|
212 | INTEGER :: maxlen |
---|
213 | INTEGER :: mask(jpi,jpj) |
---|
214 | REAL(kind=wp) :: area(jpi,jpj) |
---|
215 | |
---|
216 | CHARACTER(len=4) :: point_name ! name of the grid points |
---|
217 | |
---|
218 | REAL(kind=wp) :: rclam(jpi,jpj,4) |
---|
219 | REAL(kind=wp) :: rcphi(jpi,jpj,4) |
---|
220 | |
---|
221 | REAL(kind=wp) :: glam_b(jpi,jpj) ! buffer for orca2 grid correction |
---|
222 | REAL(kind=wp) :: gphi_b(jpi,jpj) ! buffer for orca2 grid correction |
---|
223 | !! |
---|
224 | !!-------------------------------------------------------------------- |
---|
225 | |
---|
226 | IF(lwp) WRITE(numout,*) |
---|
227 | IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case' |
---|
228 | IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' |
---|
229 | IF(lwp) WRITE(numout,*) |
---|
230 | |
---|
231 | #if defined key_flx_bulk_monthly || defined key_flx_bulk_daily || defined key_flx_forced_daily |
---|
232 | IF(lwp)WRITE(numout,cform_err) |
---|
233 | IF(lwp)WRITE(numout,*) ' key_coupled and key_flx_bulk_... are incompatible' |
---|
234 | nstop = nstop + 1 |
---|
235 | #endif |
---|
236 | |
---|
237 | ! ----------------------------------------------------------------- |
---|
238 | ! ... Some initialisation |
---|
239 | ! ----------------------------------------------------------------- |
---|
240 | |
---|
241 | send_id = 0 |
---|
242 | recv_id = 0 |
---|
243 | |
---|
244 | #if defined key_mpp_mpi |
---|
245 | |
---|
246 | ! ----------------------------------------------------------------- |
---|
247 | ! ... Some MPI stuff relevant for optional exchange via root only |
---|
248 | ! ----------------------------------------------------------------- |
---|
249 | |
---|
250 | commRank = .false. |
---|
251 | |
---|
252 | localRank = mpprank ! from lib_mpp |
---|
253 | localSize = mppsize ! from lib_mpp |
---|
254 | |
---|
255 | IF ( rootexchg ) THEN |
---|
256 | IF ( localRank == localRoot ) commRank = .true. |
---|
257 | ELSE |
---|
258 | commRank = .true. |
---|
259 | ENDIF |
---|
260 | |
---|
261 | IF ( rootexchg .and. localRank == localRoot ) THEN |
---|
262 | ALLOCATE(ranges(5,0:localSize-1), stat = ierror) |
---|
263 | IF (ierror > 0) THEN |
---|
264 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating Integer') |
---|
265 | RETURN |
---|
266 | ENDIF |
---|
267 | ENDIF |
---|
268 | |
---|
269 | #else |
---|
270 | ! |
---|
271 | ! For non-parallel configurations the one and only process ("localRoot") |
---|
272 | ! takes part in the communication |
---|
273 | ! |
---|
274 | localRank = localRoot |
---|
275 | commRank = .true. |
---|
276 | |
---|
277 | #endif |
---|
278 | |
---|
279 | ! ----------------------------------------------------------------- |
---|
280 | ! ... If necessary the root process writes the global grid info |
---|
281 | ! ----------------------------------------------------------------- |
---|
282 | |
---|
283 | IF ( localRank == localRoot ) THEN |
---|
284 | |
---|
285 | WRITE(numout,*)'Opening file SSTOCEAN, unit= 199' |
---|
286 | |
---|
287 | OPEN (199,STATUS='NEW',FILE="sstocean",FORM='UNFORMATTED',err=310) |
---|
288 | |
---|
289 | ! In case the sstocean of OASIS3 from a previous run exists |
---|
290 | ! the programs jumps to the end of the if-block |
---|
291 | ! |
---|
292 | !* 2.0 Write exchange fields to OASIS data file. |
---|
293 | ! ----------------------------------------- |
---|
294 | |
---|
295 | WHERE (tmask(:,:,1) > 0.5 ) |
---|
296 | mask(:,:) = 0 |
---|
297 | ELSE WHERE |
---|
298 | mask(:,:) = 1 |
---|
299 | END WHERE |
---|
300 | |
---|
301 | ! Initialise ice mask at the very first start only |
---|
302 | frld = 1. |
---|
303 | |
---|
304 | WRITE(199) 'SSTOCEAN' |
---|
305 | WRITE(199) (tn(:,:,1)*mask(:,:))+rt0 |
---|
306 | |
---|
307 | WRITE(199) 'SICOCEAN' |
---|
308 | WRITE(199) (1.-frld(:,:))*mask(:,:) |
---|
309 | |
---|
310 | #if defined key_cpl_albedo |
---|
311 | tn_ice = 271.285 |
---|
312 | alb_ice = 0.75 |
---|
313 | |
---|
314 | WRITE(199) 'STIOCEAN' |
---|
315 | WRITE(199) tn_ice(:,:) |
---|
316 | |
---|
317 | WRITE(199) 'SAIOCEAN' |
---|
318 | WRITE(199) alb_ice(:,:) |
---|
319 | #else |
---|
320 | hicit = 0. |
---|
321 | hsnit = 0. |
---|
322 | WRITE(199) 'SITOCEAN' |
---|
323 | WRITE(199) hicif(:,:)*mask(:,:) |
---|
324 | |
---|
325 | WRITE(199) 'SNTOCEAN' |
---|
326 | WRITE(199) hsnif(:,:)*mask(:,:) |
---|
327 | #endif |
---|
328 | |
---|
329 | #if defined key_cpl_ocevel |
---|
330 | un(:,:,1) = 0. |
---|
331 | vn(:,:,1) = 0. |
---|
332 | |
---|
333 | WHERE (umask(:,:,1) > 0.5 ) |
---|
334 | mask(:,:) = 0 |
---|
335 | ELSE WHERE |
---|
336 | mask(:,:) = 1 |
---|
337 | END WHERE |
---|
338 | |
---|
339 | WRITE(199) 'SUNOCEAN' |
---|
340 | WRITE(199) un(:,:,1)*mask(:,:) |
---|
341 | |
---|
342 | WHERE (vmask(:,:,1) > 0.5 ) |
---|
343 | mask(:,:) = 0 |
---|
344 | ELSE WHERE |
---|
345 | mask(:,:) = 1 |
---|
346 | END WHERE |
---|
347 | |
---|
348 | WRITE(199) 'SVNOCEAN' |
---|
349 | WRITE(199) vn(:,:,1)*mask(:,:) |
---|
350 | #endif |
---|
351 | |
---|
352 | WRITE(numout,*) |
---|
353 | WRITE(numout,*)' sstocean written' |
---|
354 | WRITE(numout,*)' ***************' |
---|
355 | |
---|
356 | CLOSE(199) |
---|
357 | |
---|
358 | 310 CONTINUE |
---|
359 | |
---|
360 | CALL prism_start_grids_writing ( write_grid ) |
---|
361 | |
---|
362 | ENDIF ! localRank == localRoot |
---|
363 | |
---|
364 | IF ( localRank == localRoot .and. write_grid == 1 ) THEN |
---|
365 | |
---|
366 | !------------------------------------------------------------------ |
---|
367 | ! 1st write global grid information (ORCA tripolar) characteristics |
---|
368 | ! for surface coupling into a OASIS3 specific grid file. For |
---|
369 | ! surface coupling it is sufficient to specify only one vertical |
---|
370 | ! z-level. |
---|
371 | !------------------------------------------------------------------ |
---|
372 | ! |
---|
373 | ! ... Treat corners in the horizontal plane |
---|
374 | ! |
---|
375 | nx = jpi |
---|
376 | ny = jpj |
---|
377 | nc = 4 |
---|
378 | |
---|
379 | DO i_grid = 1, 3 |
---|
380 | |
---|
381 | IF ( i_grid == 1 ) THEN |
---|
382 | |
---|
383 | ! -------------------------------------------------------- |
---|
384 | ! ... Write the grid info for T points |
---|
385 | ! -------------------------------------------------------- |
---|
386 | |
---|
387 | point_name = 'opat' |
---|
388 | |
---|
389 | glam_b = glamt |
---|
390 | gphi_b = gphit |
---|
391 | |
---|
392 | DO ji = 1, jpi |
---|
393 | DO jj = 1, jpj |
---|
394 | |
---|
395 | im1 = ji-1 |
---|
396 | jm1 = jj-1 |
---|
397 | IF (ji == 1) im1 = jpi-2 |
---|
398 | IF (jj == 1) jm1 = jj |
---|
399 | |
---|
400 | rclam(ji,jj,1) = glamf(ji,jj) |
---|
401 | rclam(ji,jj,2) = glamf(im1,jj) |
---|
402 | rclam(ji,jj,3) = glamf(im1,jm1) |
---|
403 | rclam(ji,jj,4) = glamf(ji,jm1) |
---|
404 | |
---|
405 | rcphi(ji,jj,1) = gphif(ji,jj) |
---|
406 | rcphi(ji,jj,2) = gphif(im1,jj) |
---|
407 | rcphi(ji,jj,3) = gphif(im1,jm1) |
---|
408 | rcphi(ji,jj,4) = gphif(ji,jm1) |
---|
409 | |
---|
410 | END DO |
---|
411 | END DO |
---|
412 | |
---|
413 | ! Correction of one (land) grid cell of the orca2 grid. |
---|
414 | ! It was causing problems with the SCRIP interpolation. |
---|
415 | |
---|
416 | IF (jpiglo == 182 .AND. jpjglo == 149) THEN |
---|
417 | rclam(145,106,2) = -1.0 |
---|
418 | rcphi(145,106,2) = 41.0 |
---|
419 | ENDIF |
---|
420 | |
---|
421 | WHERE (tmask(:,:,1) > 0.5 ) |
---|
422 | mask(:,:) = 0 |
---|
423 | ELSE WHERE |
---|
424 | mask(:,:) = 1 |
---|
425 | END WHERE |
---|
426 | |
---|
427 | area = e1t * e2t |
---|
428 | |
---|
429 | ELSE IF ( i_grid == 2 ) THEN |
---|
430 | |
---|
431 | ! -------------------------------------------------------- |
---|
432 | ! ... Write the grid info for u points |
---|
433 | ! -------------------------------------------------------- |
---|
434 | |
---|
435 | point_name = 'opau' |
---|
436 | |
---|
437 | glam_b = glamu |
---|
438 | gphi_b = gphiu |
---|
439 | |
---|
440 | DO ji = 1, jpi |
---|
441 | DO jj = 1, jpj |
---|
442 | |
---|
443 | ip1 = ji+1 |
---|
444 | jm1 = jj-1 |
---|
445 | |
---|
446 | IF (ji == jpiglo) ip1 = 3 |
---|
447 | IF (jj == 1) jm1 = jj |
---|
448 | |
---|
449 | rclam(ji,jj,1) = glamv(ip1,jj) |
---|
450 | rclam(ji,jj,2) = glamv(ji,jj) |
---|
451 | rclam(ji,jj,3) = glamv(ji,jm1) |
---|
452 | rclam(ji,jj,4) = glamv(ip1,jm1) |
---|
453 | |
---|
454 | rcphi(ji,jj,1) = gphiv(ip1,jj) |
---|
455 | rcphi(ji,jj,2) = gphiv(ji,jj) |
---|
456 | rcphi(ji,jj,3) = gphiv(ji,jm1) |
---|
457 | rcphi(ji,jj,4) = gphiv(ip1,jm1) |
---|
458 | |
---|
459 | END DO |
---|
460 | END DO |
---|
461 | |
---|
462 | ! Correction of three (land) grid cell of the orca2 grid. |
---|
463 | ! It was causing problems with the SCRIP interpolation. |
---|
464 | |
---|
465 | IF (jpiglo == 182 .AND. jpjglo == 149) THEN |
---|
466 | glam_b(144,106) = -1.0 |
---|
467 | gphi_b(144,106) = 40.5 |
---|
468 | rclam (144,106,2) = -1.5 |
---|
469 | rcphi (144,106,2) = 41.0 |
---|
470 | |
---|
471 | glam_b(144,107) = -1.0 |
---|
472 | gphi_b(144,107) = 41.5 |
---|
473 | rclam (144,107,2) = -1.5 |
---|
474 | rcphi (144,107,2) = 42.0 |
---|
475 | rclam (144,107,3) = -1.5 |
---|
476 | rcphi (144,107,3) = 41.0 |
---|
477 | |
---|
478 | glam_b(144,108) = -1.0 |
---|
479 | gphi_b(144,108) = 42.5 |
---|
480 | rclam (144,108,2) = -1.5 |
---|
481 | rcphi (144,108,2) = 43.0 |
---|
482 | rclam (144,108,3) = -1.5 |
---|
483 | rcphi (144,108,3) = 42.0 |
---|
484 | ENDIF |
---|
485 | |
---|
486 | WHERE (umask(:,:,1) > 0.5 ) |
---|
487 | mask(:,:) = 0 |
---|
488 | ELSE WHERE |
---|
489 | mask(:,:) = 1 |
---|
490 | END WHERE |
---|
491 | |
---|
492 | area = e1u * e2u |
---|
493 | |
---|
494 | ELSE IF ( i_grid == 3 ) THEN |
---|
495 | |
---|
496 | ! -------------------------------------------------------- |
---|
497 | ! ... Write the grid info for v points |
---|
498 | ! -------------------------------------------------------- |
---|
499 | |
---|
500 | point_name = 'opav' |
---|
501 | |
---|
502 | glam_b = glamv |
---|
503 | gphi_b = gphiv |
---|
504 | |
---|
505 | DO ji = 1, jpi |
---|
506 | DO jj = 1, jpj |
---|
507 | |
---|
508 | im1 = ji-1 |
---|
509 | jp1 = jj+1 |
---|
510 | IF (ji == 1) im1 = jpiglo-2 |
---|
511 | IF (jj == jpjglo) jp1 = jj |
---|
512 | |
---|
513 | rclam(ji,jj,1) = glamu(ji,jp1) |
---|
514 | rclam(ji,jj,2) = glamu(im1,jp1) |
---|
515 | rclam(ji,jj,3) = glamu(im1,jj) |
---|
516 | rclam(ji,jj,4) = glamu(ji,jj) |
---|
517 | |
---|
518 | rcphi(ji,jj,1) = gphiu(ji,jp1) |
---|
519 | rcphi(ji,jj,2) = gphiu(im1,jp1) |
---|
520 | rcphi(ji,jj,3) = gphiu(im1,jj) |
---|
521 | rcphi(ji,jj,4) = gphiu(ji,jj) |
---|
522 | |
---|
523 | END DO |
---|
524 | END DO |
---|
525 | |
---|
526 | ! Correction of one (land) grid cell of the orca2 grid. |
---|
527 | ! It was causing problems with the SCRIP interpolation. |
---|
528 | |
---|
529 | IF (jpiglo == 182 .AND. jpjglo == 149) THEN |
---|
530 | rclam(145,105,2) = -1.0 |
---|
531 | rcphi(145,105,2) = 40.5 |
---|
532 | ENDIF |
---|
533 | |
---|
534 | WHERE (vmask(:,:,1) > 0.5 ) |
---|
535 | mask(:,:) = 0 |
---|
536 | ELSE WHERE |
---|
537 | mask(:,:) = 1 |
---|
538 | END WHERE |
---|
539 | |
---|
540 | area = e1v * e2v |
---|
541 | |
---|
542 | ENDIF ! i_grid |
---|
543 | |
---|
544 | WHERE (glam_b(:,:) < 0.) |
---|
545 | glam_b(:,:) = glam_b(:,:) + 360. |
---|
546 | END WHERE |
---|
547 | WHERE (glam_b(:,:) > 360.) |
---|
548 | glam_b(:,:) = glam_b(:,:) - 360. |
---|
549 | END WHERE |
---|
550 | |
---|
551 | WHERE (rclam(:,:,:) < 0.) |
---|
552 | rclam(:,:,:) = rclam(:,:,:) + 360. |
---|
553 | END WHERE |
---|
554 | WHERE (rclam(:,:,:) > 360.) |
---|
555 | rclam(:,:,:) = rclam(:,:,:) - 360. |
---|
556 | END WHERE |
---|
557 | |
---|
558 | mask(:,jpjglo)=1 |
---|
559 | |
---|
560 | CALL prism_write_grid ( point_name, nx, ny, glam_b, gphi_b ) |
---|
561 | CALL prism_write_corner ( point_name, nx, ny, nc, rclam, rcphi ) |
---|
562 | CALL prism_write_mask ( point_name, nx, ny, mask ) |
---|
563 | CALL prism_write_area ( point_name, nx, ny, area ) |
---|
564 | |
---|
565 | END DO ! i_grid |
---|
566 | |
---|
567 | CALL prism_terminate_grids_writing () |
---|
568 | |
---|
569 | ENDIF ! localRank == localRoot .and. write_grid == 1 |
---|
570 | |
---|
571 | ! ----------------------------------------------------------------- |
---|
572 | ! ... Define the partition |
---|
573 | ! ----------------------------------------------------------------- |
---|
574 | |
---|
575 | IF ( rootexchg ) THEN |
---|
576 | |
---|
577 | paral(1) = 2 ! box partitioning |
---|
578 | paral(2) = 0 ! NEMO lower left corner global offset |
---|
579 | paral(3) = jpiglo ! local extent in i |
---|
580 | paral(4) = jpjglo ! local extent in j |
---|
581 | paral(5) = jpiglo ! global extent in x |
---|
582 | |
---|
583 | range(1) = nimpp-1+nldi ! global start in i |
---|
584 | range(2) = nlei-nldi+1 ! local size in i of valid region |
---|
585 | range(3) = njmpp-1+nldj ! global start in j |
---|
586 | range(4) = nlej-nldj+1 ! local size in j of valid region |
---|
587 | range(5) = range(2) & |
---|
588 | * range(4) ! local horizontal size |
---|
589 | |
---|
590 | IF(ln_ctl) THEN |
---|
591 | write(numout,*) ' rootexchg: range(1:5)', range |
---|
592 | ENDIF |
---|
593 | |
---|
594 | ! |
---|
595 | ! Collect ranges from all NEMO procs on the local root process |
---|
596 | ! |
---|
597 | CALL mpi_gather(range, 5, MPI_INTEGER, & |
---|
598 | ranges, 5, MPI_INTEGER, localRoot, localComm, ierror) |
---|
599 | |
---|
600 | IF ( localRank == localRoot ) THEN |
---|
601 | |
---|
602 | maxlen = maxval(ranges(5,:)) |
---|
603 | |
---|
604 | ALLOCATE(buffer(1:maxlen), stat = ierror) |
---|
605 | IF (ierror > 0) THEN |
---|
606 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating buffer') |
---|
607 | RETURN |
---|
608 | ENDIF |
---|
609 | |
---|
610 | ENDIF |
---|
611 | |
---|
612 | ELSE |
---|
613 | |
---|
614 | paral(1) = 2 ! box partitioning |
---|
615 | !2dtest paral(2) = jpiglo & |
---|
616 | !2dtest * (nldj-1+njmpp-1) & |
---|
617 | !2dtest + (nldi-1+nimpp-1) ! NEMO lower left corner global offset |
---|
618 | paral(2) = jpiglo & |
---|
619 | * (nldj-1+njmpp-1) ! NEMO lower left corner global offset |
---|
620 | paral(3) = nlei-nldi+1 ! local extent in i |
---|
621 | paral(4) = nlej-nldj+1 ! local extent in j |
---|
622 | paral(5) = jpiglo ! global extent in x |
---|
623 | |
---|
624 | IF(ln_ctl) THEN |
---|
625 | print*, ' multiexchg: paral (1:5)', paral |
---|
626 | print*, ' multiexchg: jpi, jpj =', jpi, jpj |
---|
627 | print*, ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp |
---|
628 | print*, ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp |
---|
629 | ENDIF |
---|
630 | |
---|
631 | IF ( paral(3) /= nlei-nldi+1 ) THEN |
---|
632 | print*, 'WARNING!!! in cpl_oasis3 - cpl_prism_define' |
---|
633 | print*, 'cpl_prism_define: local extend in i is ', paral(3), ' should equal ', nlei-nldi+1 |
---|
634 | ENDIF |
---|
635 | IF ( paral(4) /= nlej-nldj+1 ) THEN |
---|
636 | print*, 'WARNING!!! in cpl_oasis3 - cpl_prism_define' |
---|
637 | print*, 'cpl_prism_define: local extend in j is ', paral(4), ' should equal ', nlej-nldj+1 |
---|
638 | ENDIF |
---|
639 | |
---|
640 | ENDIF |
---|
641 | |
---|
642 | IF ( commRank ) & |
---|
643 | CALL prism_def_partition_proto ( part_id, paral, ierror ) |
---|
644 | |
---|
645 | grid_id(1)= part_id |
---|
646 | |
---|
647 | !------------------------------------------------------------------ |
---|
648 | ! 3rd Declare the transient variables |
---|
649 | !------------------------------------------------------------------ |
---|
650 | ! |
---|
651 | ! ... Define symbolic names for the transient fields send by the ocean |
---|
652 | ! These must be identical to the names specified in the SMIOC file. |
---|
653 | ! |
---|
654 | cpl_send( 1)='SSTOCEAN' ! sea surface temperature -> sst_io |
---|
655 | cpl_send( 2)='SICOCEAN' ! sea ice area fraction -> 1.-frld |
---|
656 | #if defined key_cpl_albedo |
---|
657 | cpl_send( 3)='STIOCEAN' ! surface temperature over sea ice -> tn_ice |
---|
658 | cpl_send( 4)='SAIOCEAN' ! albedo over sea ice -> alb_ice |
---|
659 | #else |
---|
660 | cpl_send( 3)='SITOCEAN' ! sea ice thickness -> hicif (only 1 layer available!) |
---|
661 | cpl_send( 4)='SNTOCEAN' ! surface snow thickness over sea ice -> hsnif |
---|
662 | #endif |
---|
663 | #if defined key_cpl_ocevel |
---|
664 | cpl_send( 5)='SUNOCEAN' ! U-velocity -> un |
---|
665 | cpl_send( 6)='SVNOCEAN' ! V-velocity -> vn |
---|
666 | #endif |
---|
667 | ! |
---|
668 | ! ... Define symbolic names for transient fields received by the ocean. |
---|
669 | ! These must be identical to the names specified in the SMIOC file. |
---|
670 | ! |
---|
671 | ! ... a) U-Grid fields |
---|
672 | ! |
---|
673 | cpl_recv( 1)='TXWOCEWU' ! weighted surface downward eastward stress |
---|
674 | cpl_recv( 2)='TYWOCEWU' ! weighted surface downward northward stress |
---|
675 | cpl_recv( 3)='TXIOCEWU' ! weighted surface downward eastward stress over ice |
---|
676 | cpl_recv( 4)='TYIOCEWU' ! weighted surface downward northward stress over ice |
---|
677 | ! |
---|
678 | ! ... a) V-Grid fields |
---|
679 | ! |
---|
680 | cpl_recv( 5)='TXWOCEWV' ! weighted surface downward eastward stress |
---|
681 | cpl_recv( 6)='TYWOCEWV' ! weighted surface downward northward stress |
---|
682 | cpl_recv( 7)='TXIOCEWV' ! weighted surface downward eastward stress over ice |
---|
683 | cpl_recv( 8)='TYIOCEWV' ! weighted surface downward northward stress over ice |
---|
684 | ! |
---|
685 | ! ... a) T-Grid fields |
---|
686 | ! |
---|
687 | cpl_recv( 9)='FRWOCEPE' ! P-E over water -> zpew |
---|
688 | cpl_recv(10)='FRIOCEPE' ! P-E over ice -> zpei |
---|
689 | cpl_recv(11)='FRROCESN' ! surface downward snow fall -> zpsol |
---|
690 | cpl_recv(12)='FRIOCEEV' ! surface upward snow flux where sea ice -> zevice |
---|
691 | |
---|
692 | cpl_recv(13)='QSWOCESR' ! surface net downward shortwave flux -> qsr_oce |
---|
693 | cpl_recv(14)='QSWOCENS' ! surface downward non-solar heat flux in air -> qnsr_oce |
---|
694 | cpl_recv(15)='QSIOCESR' ! solar heat flux on sea ice -> qsr_ice |
---|
695 | cpl_recv(16)='QSIOCENS' ! non-solar heat flux on sea ice -> qnsr_ice |
---|
696 | cpl_recv(17)='QSIOCEDQ' ! non-solar heat flux derivative -> dqns_ice |
---|
697 | |
---|
698 | #ifdef key_cpl_discharge |
---|
699 | cpl_recv(18)='FRWOCEIS' ! ice discharge into ocean -> calving |
---|
700 | cpl_recv(19)='FRWOCERD' ! river discharge into ocean -> zrunriv |
---|
701 | cpl_recv(20)='FRWOCECD' ! continental discharge into ocean -> zruncot |
---|
702 | #endif |
---|
703 | ! |
---|
704 | ! data_type has to be PRISM_REAL as PRISM_DOUBLE is not supported. |
---|
705 | ! For exchange of double precision fields the OASIS3 has to be compiled |
---|
706 | ! with use_realtype_single. (see OASIS3 User Guide prism_2-4, 5th Ed., |
---|
707 | ! p. 13 and p. 53 for further explanation.) |
---|
708 | ! |
---|
709 | data_type = PRISM_REAL |
---|
710 | |
---|
711 | nodim(1) = 3 ! check |
---|
712 | nodim(2) = 0 |
---|
713 | |
---|
714 | ! |
---|
715 | ! ... Define the shape for the area that excludes the halo |
---|
716 | ! For serial configuration (key_mpp_mpi not being active) |
---|
717 | ! nl* is set to the global values 1 and jp*glo. |
---|
718 | ! |
---|
719 | IF ( rootexchg ) THEN |
---|
720 | shape(1,1) = 1 |
---|
721 | shape(2,1) = jpiglo |
---|
722 | shape(1,2) = 1 |
---|
723 | shape(2,2) = jpjglo |
---|
724 | shape(1,3) = 1 |
---|
725 | shape(2,3) = 1 |
---|
726 | ELSE |
---|
727 | shape(1,1) = 1 |
---|
728 | shape(2,1) = nlei-nldi+1 ! jpi |
---|
729 | shape(1,2) = 1 |
---|
730 | shape(2,2) = nlej-nldj+1 ! jpj |
---|
731 | shape(1,3) = 1 |
---|
732 | shape(2,3) = 1 |
---|
733 | ENDIF |
---|
734 | ! |
---|
735 | ! ----------------------------------------------------------------- |
---|
736 | ! ... Allocate memory for data exchange |
---|
737 | ! ----------------------------------------------------------------- |
---|
738 | ! |
---|
739 | ALLOCATE(exfld(shape(1,1):shape(2,1),shape(1,2):shape(2,2)), stat = ierror) |
---|
740 | IF (ierror > 0) THEN |
---|
741 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating exfld') |
---|
742 | RETURN |
---|
743 | ENDIF |
---|
744 | ! |
---|
745 | ! ... Announce send variables, all on T points. |
---|
746 | ! |
---|
747 | info = PRISM_Out |
---|
748 | ! |
---|
749 | |
---|
750 | IF ( commRank ) THEN |
---|
751 | |
---|
752 | DO ji = 1, nsend |
---|
753 | ! if ( ji == 2 ) ; then ; nodim(2) = 2 ; else ; nodim(2) = 0 ; endif |
---|
754 | CALL prism_def_var_proto (send_id(ji), cpl_send(ji), grid_id(1), & |
---|
755 | nodim, info, shape, data_type, ierror) |
---|
756 | IF ( ierror /= PRISM_Ok ) THEN |
---|
757 | PRINT *, 'Failed to define transient ', ji, TRIM(cpl_send(ji)) |
---|
758 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
759 | ENDIF |
---|
760 | ENDDO |
---|
761 | ! |
---|
762 | nodim(1) = 3 ! check |
---|
763 | nodim(2) = 0 |
---|
764 | ! |
---|
765 | ! ... Announce recv variables. |
---|
766 | ! |
---|
767 | info = PRISM_In |
---|
768 | ! |
---|
769 | ! ... a) on U points |
---|
770 | ! |
---|
771 | DO ji = 1, 4 |
---|
772 | CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), & |
---|
773 | nodim, info, shape, data_type, ierror) |
---|
774 | IF ( ierror /= PRISM_Ok ) THEN |
---|
775 | PRINT *, 'Failed to define transient ', ji, TRIM(cpl_recv(ji)) |
---|
776 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
777 | ENDIF |
---|
778 | ENDDO |
---|
779 | ! |
---|
780 | ! ... b) on V points |
---|
781 | ! |
---|
782 | DO ji = 5, 8 |
---|
783 | CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), & |
---|
784 | nodim, info, shape, data_type, ierror) |
---|
785 | IF ( ierror /= PRISM_Ok ) THEN |
---|
786 | PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) |
---|
787 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
788 | ENDIF |
---|
789 | ENDDO |
---|
790 | ! |
---|
791 | ! ... c) on T points |
---|
792 | ! |
---|
793 | DO ji = 9, nrecv |
---|
794 | CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), & |
---|
795 | nodim, info, shape, data_type, ierror) |
---|
796 | IF ( ierror /= PRISM_Ok ) THEN |
---|
797 | PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) |
---|
798 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var') |
---|
799 | ENDIF |
---|
800 | ENDDO |
---|
801 | |
---|
802 | ENDIF ! commRank |
---|
803 | |
---|
804 | !------------------------------------------------------------------ |
---|
805 | ! 4th End of definition phase |
---|
806 | !------------------------------------------------------------------ |
---|
807 | |
---|
808 | IF ( commRank ) THEN |
---|
809 | CALL prism_enddef_proto(ierror) |
---|
810 | IF ( ierror /= PRISM_Ok ) & |
---|
811 | CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_enddef') |
---|
812 | ENDIF |
---|
813 | |
---|
814 | END SUBROUTINE cpl_prism_define |
---|
815 | |
---|
816 | |
---|
817 | |
---|
818 | SUBROUTINE cpl_prism_send( var_id, date, data_array, info ) |
---|
819 | |
---|
820 | IMPLICIT NONE |
---|
821 | |
---|
822 | !!--------------------------------------------------------------------- |
---|
823 | !! *** ROUTINE cpl_prism_send *** |
---|
824 | !! |
---|
825 | !! ** Purpose : - At each coupling time-step,this routine sends fields |
---|
826 | !! like sst or ice cover to the coupler or remote application. |
---|
827 | !!---------------------------------------------------------------------- |
---|
828 | !! * Arguments |
---|
829 | !! |
---|
830 | INTEGER, INTENT( IN ) :: var_id ! variable Id |
---|
831 | INTEGER, INTENT( OUT ) :: info ! OASIS3 info argument |
---|
832 | INTEGER, INTENT( IN ) :: date ! ocean time-step in seconds |
---|
833 | REAL(wp) :: data_array(:,:) |
---|
834 | !! |
---|
835 | !! * Local declarations |
---|
836 | !! |
---|
837 | #if defined key_mpp_mpi |
---|
838 | REAL(wp) :: global_array(jpiglo,jpjglo) |
---|
839 | ! |
---|
840 | !mpi INTEGER :: status(MPI_STATUS_SIZE) |
---|
841 | !mpi INTEGER :: type ! MPI data type |
---|
842 | INTEGER :: request ! MPI isend request |
---|
843 | INTEGER :: ji, jj, jn ! local loop indicees |
---|
844 | #else |
---|
845 | INTEGER :: ji |
---|
846 | #endif |
---|
847 | !! |
---|
848 | !!-------------------------------------------------------------------- |
---|
849 | !! |
---|
850 | |
---|
851 | #if defined key_mpp_mpi |
---|
852 | |
---|
853 | request = 0 |
---|
854 | |
---|
855 | IF ( rootexchg ) THEN |
---|
856 | ! |
---|
857 | !mpi IF ( wp == 4 ) type = MPI_REAL |
---|
858 | !mpi IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION |
---|
859 | ! |
---|
860 | ! collect data on the local root process |
---|
861 | ! |
---|
862 | |
---|
863 | if ( var_id == 1 .and. localRank == localRoot .and. ln_ctl ) then |
---|
864 | do ji = 0, localSize-1 |
---|
865 | WRITE(numout,*) ' rootexchg: ranges for rank ', ji, ' are ', ranges(:,ji) |
---|
866 | enddo |
---|
867 | endif |
---|
868 | |
---|
869 | IF ( localRank /= localRoot ) THEN |
---|
870 | |
---|
871 | DO jj = nldj, nlej |
---|
872 | DO ji = nldi, nlei |
---|
873 | exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) |
---|
874 | ENDDO |
---|
875 | ENDDO |
---|
876 | |
---|
877 | !mpi CALL mpi_send(exfld, range(5), type, localRoot, localRank, localComm, ierror) |
---|
878 | CALL mppsend (localRank, exfld, range(5), localRoot, request) |
---|
879 | |
---|
880 | if ( var_id == 1 .and. ln_ctl ) then |
---|
881 | WRITE(numout,*) ' rootexchg: This is process ', localRank |
---|
882 | WRITE(numout,*) ' rootexchg: We have a range of ', range |
---|
883 | ! WRITE(numout,*) ' rootexchg: We got SST to process ', data_array |
---|
884 | endif |
---|
885 | |
---|
886 | ENDIF |
---|
887 | |
---|
888 | IF ( localRank == localRoot ) THEN |
---|
889 | |
---|
890 | DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 |
---|
891 | DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 |
---|
892 | global_array(ji,jj) = data_array(ji,jj) ! workaround |
---|
893 | ENDDO |
---|
894 | ENDDO |
---|
895 | |
---|
896 | DO jn = 1, localSize-1 |
---|
897 | |
---|
898 | !mpi CALL mpi_recv(buffer, ranges(5,jn), type, localRoot, jn, localComm, status, ierror) |
---|
899 | CALL mpprecv(jn, buffer, ranges(5,jn)) |
---|
900 | |
---|
901 | if ( var_id == 1 .and. ln_ctl ) then |
---|
902 | WRITE(numout,*) ' rootexchg: Handling data from process ', jn |
---|
903 | ! WRITE(numout,*) ' rootexchg: We got SST to process ', buffer |
---|
904 | endif |
---|
905 | |
---|
906 | |
---|
907 | DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 |
---|
908 | DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 |
---|
909 | global_array(ji,jj) = buffer((jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1) |
---|
910 | ENDDO |
---|
911 | ENDDO |
---|
912 | |
---|
913 | ENDDO |
---|
914 | |
---|
915 | CALL prism_put_proto ( var_id, date, global_array, info ) |
---|
916 | |
---|
917 | ENDIF |
---|
918 | |
---|
919 | ELSE |
---|
920 | |
---|
921 | DO jj = nldj, nlej |
---|
922 | DO ji = nldi, nlei |
---|
923 | exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) |
---|
924 | ENDDO |
---|
925 | ENDDO |
---|
926 | |
---|
927 | CALL prism_put_proto ( var_id, date, exfld, info ) |
---|
928 | |
---|
929 | ENDIF |
---|
930 | |
---|
931 | #else |
---|
932 | |
---|
933 | ! |
---|
934 | ! send local data from every process to OASIS3 |
---|
935 | ! |
---|
936 | IF ( commRank ) & |
---|
937 | CALL prism_put_proto ( var_id, date, data_array, info ) |
---|
938 | |
---|
939 | #endif |
---|
940 | |
---|
941 | IF ( commRank ) THEN |
---|
942 | |
---|
943 | IF (ln_ctl .and. lwp) THEN |
---|
944 | |
---|
945 | IF ( info == PRISM_Sent .OR. & |
---|
946 | info == PRISM_ToRest .OR. & |
---|
947 | info == PRISM_SentOut .OR. & |
---|
948 | info == PRISM_ToRestOut ) THEN |
---|
949 | WRITE(numout,*) '****************' |
---|
950 | DO ji = 1, nsend |
---|
951 | IF (var_id == send_id(ji) ) THEN |
---|
952 | WRITE(numout,*) 'prism_put_proto: Outgoing ', cpl_send(ji) |
---|
953 | EXIT |
---|
954 | ENDIF |
---|
955 | ENDDO |
---|
956 | WRITE(numout,*) 'prism_put_proto: var_id ', var_id |
---|
957 | WRITE(numout,*) 'prism_put_proto: date ', date |
---|
958 | WRITE(numout,*) 'prism_put_proto: info ', info |
---|
959 | WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) |
---|
960 | WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) |
---|
961 | WRITE(numout,*) ' - Sum value is ', SUM(data_array) |
---|
962 | WRITE(numout,*) '****************' |
---|
963 | ENDIF |
---|
964 | |
---|
965 | ENDIF |
---|
966 | |
---|
967 | ENDIF |
---|
968 | |
---|
969 | END SUBROUTINE cpl_prism_send |
---|
970 | |
---|
971 | |
---|
972 | |
---|
973 | SUBROUTINE cpl_prism_recv( var_id, date, data_array, info ) |
---|
974 | |
---|
975 | IMPLICIT NONE |
---|
976 | |
---|
977 | !!--------------------------------------------------------------------- |
---|
978 | !! *** ROUTINE cpl_prism_recv *** |
---|
979 | !! |
---|
980 | !! ** Purpose : - At each coupling time-step,this routine receives fields |
---|
981 | !! like stresses and fluxes from the coupler or remote application. |
---|
982 | !!---------------------------------------------------------------------- |
---|
983 | !! * Arguments |
---|
984 | !! |
---|
985 | INTEGER, INTENT( IN ) :: var_id ! variable Id |
---|
986 | INTEGER, INTENT( OUT ) :: info ! variable Id |
---|
987 | INTEGER, INTENT( IN ) :: date ! ocean time-step in seconds |
---|
988 | REAL(wp),INTENT( OUT ) :: data_array(:,:) |
---|
989 | !! |
---|
990 | !! * Local declarations |
---|
991 | !! |
---|
992 | #if defined key_mpp_mpi |
---|
993 | REAL(wp) :: global_array(jpiglo,jpjglo) |
---|
994 | ! |
---|
995 | ! LOGICAL :: action = .false. |
---|
996 | LOGICAL :: action |
---|
997 | !mpi INTEGER :: status(MPI_STATUS_SIZE) |
---|
998 | !mpi INTEGER :: type ! MPI data type |
---|
999 | INTEGER :: request ! MPI isend request |
---|
1000 | INTEGER :: ji, jj, jn ! local loop indices |
---|
1001 | #else |
---|
1002 | INTEGER :: ji |
---|
1003 | #endif |
---|
1004 | !! |
---|
1005 | !!-------------------------------------------------------------------- |
---|
1006 | !! |
---|
1007 | #ifdef key_mpp_mpi |
---|
1008 | action = .false. |
---|
1009 | request = 0 |
---|
1010 | |
---|
1011 | IF ( rootexchg ) THEN |
---|
1012 | ! |
---|
1013 | ! receive data from OASIS3 on local root |
---|
1014 | ! |
---|
1015 | IF ( commRank ) & |
---|
1016 | CALL prism_get_proto ( var_id, date, global_array, info ) |
---|
1017 | |
---|
1018 | CALL MPI_BCAST ( info, 1, MPI_INTEGER, localRoot, localComm, ierror ) |
---|
1019 | |
---|
1020 | ELSE |
---|
1021 | ! |
---|
1022 | ! receive local data from OASIS3 on every process |
---|
1023 | ! |
---|
1024 | CALL prism_get_proto ( var_id, date, exfld, info ) |
---|
1025 | |
---|
1026 | ENDIF |
---|
1027 | |
---|
1028 | IF ( info == PRISM_Recvd .OR. & |
---|
1029 | info == PRISM_FromRest .OR. & |
---|
1030 | info == PRISM_RecvOut .OR. & |
---|
1031 | info == PRISM_FromRestOut ) action = .true. |
---|
1032 | |
---|
1033 | IF (ln_ctl .and. lwp) THEN |
---|
1034 | WRITE(numout,*) "info", info, var_id |
---|
1035 | WRITE(numout,*) "date", date, var_id |
---|
1036 | WRITE(numout,*) "action", action, var_id |
---|
1037 | ENDIF |
---|
1038 | |
---|
1039 | IF ( rootexchg .and. action ) THEN |
---|
1040 | ! |
---|
1041 | !mpi IF ( wp == 4 ) type = MPI_REAL |
---|
1042 | !mpi IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION |
---|
1043 | ! |
---|
1044 | ! distribute data to processes |
---|
1045 | ! |
---|
1046 | IF ( localRank == localRoot ) THEN |
---|
1047 | |
---|
1048 | DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 |
---|
1049 | DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 |
---|
1050 | exfld(ji-ranges(1,localRoot)+1,jj-ranges(3,localRoot)+1) = global_array(ji,jj) |
---|
1051 | ENDDO |
---|
1052 | ENDDO |
---|
1053 | |
---|
1054 | DO jn = 1, localSize-1 |
---|
1055 | |
---|
1056 | DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 |
---|
1057 | DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 |
---|
1058 | buffer((jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1) = global_array(ji,jj) |
---|
1059 | ENDDO |
---|
1060 | ENDDO |
---|
1061 | |
---|
1062 | !mpi CALL mpi_send(buffer, ranges(5,jn), type, jn, jn, localComm, ierror) |
---|
1063 | CALL mppsend (jn, buffer, ranges(5,jn), jn, request) |
---|
1064 | |
---|
1065 | ENDDO |
---|
1066 | |
---|
1067 | ENDIF |
---|
1068 | |
---|
1069 | IF ( localRank /= localRoot ) THEN |
---|
1070 | !mpi CALL mpi_recv(exfld, range(5), type, localRoot, localRank, localComm, status, ierror) |
---|
1071 | CALL mpprecv(localRank, exfld, range(5)) |
---|
1072 | ENDIF |
---|
1073 | |
---|
1074 | ENDIF |
---|
1075 | |
---|
1076 | IF ( action ) THEN |
---|
1077 | |
---|
1078 | data_array = 0.0 |
---|
1079 | |
---|
1080 | DO jj = nldj, nlej |
---|
1081 | DO ji = nldi, nlei |
---|
1082 | data_array(ji,jj)=exfld(ji-nldi+1,jj-nldj+1) |
---|
1083 | ENDDO |
---|
1084 | ENDDO |
---|
1085 | |
---|
1086 | IF (ln_ctl .and. lwp) THEN |
---|
1087 | WRITE(numout,*) '****************' |
---|
1088 | DO ji = 1, nrecv |
---|
1089 | IF (var_id == recv_id(ji) ) THEN |
---|
1090 | WRITE(numout,*) 'prism_get_proto: Incoming ', cpl_recv(ji) |
---|
1091 | EXIT |
---|
1092 | ENDIF |
---|
1093 | ENDDO |
---|
1094 | WRITE(numout,*) 'prism_get_proto: var_id ', var_id |
---|
1095 | WRITE(numout,*) 'prism_get_proto: date ', date |
---|
1096 | WRITE(numout,*) 'prism_get_proto: info ', info |
---|
1097 | WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) |
---|
1098 | WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) |
---|
1099 | WRITE(numout,*) ' - Sum value is ', SUM(data_array) |
---|
1100 | WRITE(numout,*) '****************' |
---|
1101 | ENDIF |
---|
1102 | |
---|
1103 | ENDIF |
---|
1104 | #else |
---|
1105 | CALL prism_get_proto ( var_id, date, exfld, info) |
---|
1106 | |
---|
1107 | IF (info == PRISM_Recvd .OR. & |
---|
1108 | info == PRISM_FromRest .OR. & |
---|
1109 | info == PRISM_RecvOut .OR. & |
---|
1110 | info == PRISM_FromRestOut ) THEN |
---|
1111 | data_array = exfld |
---|
1112 | |
---|
1113 | IF (ln_ctl .and. lwp ) THEN |
---|
1114 | WRITE(numout,*) '****************' |
---|
1115 | DO ji = 1, nrecv |
---|
1116 | IF (var_id == recv_id(ji) ) THEN |
---|
1117 | WRITE(numout,*) 'prism_get_proto: Incoming ', cpl_recv(ji) |
---|
1118 | EXIT |
---|
1119 | ENDIF |
---|
1120 | ENDDO |
---|
1121 | WRITE(numout,*) 'prism_get_proto: var_id ', var_id |
---|
1122 | WRITE(numout,*) 'prism_get_proto: date ', date |
---|
1123 | WRITE(numout,*) 'prism_get_proto: info ', info |
---|
1124 | WRITE(numout,*) ' - Minimum value is ', MINVAL(data_array) |
---|
1125 | WRITE(numout,*) ' - Maximum value is ', MAXVAL(data_array) |
---|
1126 | WRITE(numout,*) ' - Sum value is ', SUM(data_array) |
---|
1127 | WRITE(numout,*) '****************' |
---|
1128 | ENDIF |
---|
1129 | |
---|
1130 | ENDIF |
---|
1131 | #endif |
---|
1132 | |
---|
1133 | END SUBROUTINE cpl_prism_recv |
---|
1134 | |
---|
1135 | |
---|
1136 | |
---|
1137 | SUBROUTINE cpl_prism_finalize |
---|
1138 | |
---|
1139 | IMPLICIT NONE |
---|
1140 | |
---|
1141 | !!--------------------------------------------------------------------- |
---|
1142 | !! *** ROUTINE cpl_prism_finalize *** |
---|
1143 | !! |
---|
1144 | !! ** Purpose : - Finalizes the coupling. If MPI_init has not been |
---|
1145 | !! called explicitly before cpl_prism_init it will also close |
---|
1146 | !! MPI communication. |
---|
1147 | !!---------------------------------------------------------------------- |
---|
1148 | |
---|
1149 | DEALLOCATE(exfld) |
---|
1150 | |
---|
1151 | if ( prism_was_initialized ) then |
---|
1152 | |
---|
1153 | if ( prism_was_terminated ) then |
---|
1154 | print *, 'prism has already been terminated.' |
---|
1155 | else |
---|
1156 | call prism_terminate_proto ( ierror ) |
---|
1157 | prism_was_terminated = .true. |
---|
1158 | endif |
---|
1159 | |
---|
1160 | else |
---|
1161 | |
---|
1162 | print *, 'Initialize prism before terminating it.' |
---|
1163 | |
---|
1164 | endif |
---|
1165 | |
---|
1166 | |
---|
1167 | END SUBROUTINE cpl_prism_finalize |
---|
1168 | |
---|
1169 | #endif |
---|
1170 | |
---|
1171 | END MODULE cpl_oasis3 |
---|