New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

cpl_oasis3.F90 in branches/dev_001_SBC/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: branches/dev_001_SBC/NEMO/OPA_SRC/SBC/cpl_oasis3.F90 @ 886

Last change on this file since 886 was 886, checked in by ctlod, 16 years ago
dev_001_SBC: Step II: adapt new SBC to LIM 3.0 component, see ticket: #112
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 40.7 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: