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 trunk/NEMO/OPA_SRC/SBC – NEMO

Context Navigation

source: trunk/NEMO/OPA_SRC/SBC/cpl_oasis3.F90 @ 719

Last change on this file since 719 was 719, checked in by ctlod, 17 years ago
get back to the nemo_v2_3 version for trunk
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
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 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

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

Download in other formats: