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

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

Last change on this file since 881 was 881, checked in by ctlod, 16 years ago

dev_001_SBC: Step I: change cpp ket name key_ice_lim into key_lim2 & change names inside modules with extension _2, see ticket: #110

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 40.7 KB
Line 
1MODULE 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
121CONTAINS
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         tn_ice  = 271.285
311    alb_ice =   0.75
312
313         WRITE(199) 'STIOCEAN'
314         WRITE(199) tn_ice(:,:)
315
316         WRITE(199) 'SAIOCEAN'
317         WRITE(199) alb_ice(:,:)
318#else
319         hicit = 0.
320         hsnit = 0.
321         WRITE(199) 'SITOCEAN'
322         WRITE(199) hicif(:,:)*mask(:,:)
323
324         WRITE(199) 'SNTOCEAN'
325         WRITE(199) hsnif(:,:)*mask(:,:)
326#endif
327
328#if defined key_cpl_ocevel
329         un(:,:,1) = 0.
330         vn(:,:,1) = 0.
331
332         WHERE (umask(:,:,1) > 0.5 )
333            mask(:,:) = 0
334         ELSE WHERE
335            mask(:,:) = 1
336         END WHERE
337
338         WRITE(199) 'SUNOCEAN'
339         WRITE(199) un(:,:,1)*mask(:,:)
340
341         WHERE (vmask(:,:,1) > 0.5 )
342            mask(:,:) = 0
343         ELSE WHERE
344            mask(:,:) = 1
345         END WHERE
346
347         WRITE(199) 'SVNOCEAN'
348         WRITE(199) vn(:,:,1)*mask(:,:)
349#endif
350
351         WRITE(numout,*)
352         WRITE(numout,*)' sstocean written'
353         WRITE(numout,*)' ***************'
354
355         CLOSE(199)
356
357 310     CONTINUE
358
359         CALL prism_start_grids_writing ( write_grid )
360
361      ENDIF  ! localRank == localRoot
362
363      IF ( localRank == localRoot .and. write_grid == 1 ) THEN
364
365         !------------------------------------------------------------------
366         ! 1st write global grid information (ORCA tripolar) characteristics
367         !     for surface coupling into a OASIS3 specific grid file. For
368         !     surface coupling it is sufficient to specify only one vertical
369         !     z-level.
370         !------------------------------------------------------------------
371         !
372         ! ... Treat corners in the horizontal plane
373         !
374         nx = jpi
375         ny = jpj
376         nc = 4
377
378         DO i_grid = 1, 3
379
380            IF ( i_grid == 1 ) THEN
381
382               ! --------------------------------------------------------
383               ! ... Write the grid info for T points
384               ! --------------------------------------------------------
385
386               point_name = 'opat'
387
388               glam_b = glamt
389               gphi_b = gphit
390
391               DO ji = 1, jpi
392                  DO jj = 1, jpj
393
394                     im1 = ji-1
395                     jm1 = jj-1
396                     IF (ji == 1) im1 = jpi-2
397                     IF (jj == 1) jm1 = jj
398
399                     rclam(ji,jj,1) = glamf(ji,jj)
400                     rclam(ji,jj,2) = glamf(im1,jj)
401                     rclam(ji,jj,3) = glamf(im1,jm1)
402                     rclam(ji,jj,4) = glamf(ji,jm1)
403
404                     rcphi(ji,jj,1) = gphif(ji,jj)
405                     rcphi(ji,jj,2) = gphif(im1,jj)
406                     rcphi(ji,jj,3) = gphif(im1,jm1)
407                     rcphi(ji,jj,4) = gphif(ji,jm1)
408
409                  END DO
410               END DO
411
412               ! Correction of one (land) grid cell of the orca2 grid.
413               ! It was causing problems with the SCRIP interpolation.
414
415               IF (jpiglo == 182 .AND. jpjglo == 149) THEN
416                  rclam(145,106,2) = -1.0
417                  rcphi(145,106,2) = 41.0
418               ENDIF
419
420               WHERE (tmask(:,:,1) > 0.5 )
421                  mask(:,:) = 0
422               ELSE WHERE
423                  mask(:,:) = 1
424               END WHERE
425
426               area = e1t * e2t
427
428            ELSE IF ( i_grid == 2 ) THEN
429
430               ! --------------------------------------------------------
431               ! ... Write the grid info for u points
432               ! --------------------------------------------------------
433
434               point_name = 'opau'
435
436               glam_b = glamu
437               gphi_b = gphiu
438
439               DO ji = 1, jpi
440                  DO jj = 1, jpj
441
442                     ip1 = ji+1
443                     jm1 = jj-1
444
445                     IF (ji == jpiglo) ip1 = 3
446                     IF (jj == 1) jm1 = jj
447
448                     rclam(ji,jj,1) = glamv(ip1,jj)
449                     rclam(ji,jj,2) = glamv(ji,jj)
450                     rclam(ji,jj,3) = glamv(ji,jm1)
451                     rclam(ji,jj,4) = glamv(ip1,jm1)
452
453                     rcphi(ji,jj,1) = gphiv(ip1,jj)
454                     rcphi(ji,jj,2) = gphiv(ji,jj)
455                     rcphi(ji,jj,3) = gphiv(ji,jm1)
456                     rcphi(ji,jj,4) = gphiv(ip1,jm1)
457
458                  END DO
459               END DO
460
461               ! Correction of three (land) grid cell of the orca2 grid.
462               ! It was causing problems with the SCRIP interpolation.
463
464               IF (jpiglo == 182 .AND. jpjglo == 149) THEN
465                  glam_b(144,106)   = -1.0
466                  gphi_b(144,106)   = 40.5
467                  rclam (144,106,2) = -1.5 
468                  rcphi (144,106,2) = 41.0
469
470                  glam_b(144,107)   = -1.0
471                  gphi_b(144,107)   = 41.5
472                  rclam (144,107,2) = -1.5 
473                  rcphi (144,107,2) = 42.0
474                  rclam (144,107,3) = -1.5 
475                  rcphi (144,107,3) = 41.0
476
477                  glam_b(144,108)   = -1.0
478                  gphi_b(144,108)   = 42.5
479                  rclam (144,108,2) = -1.5 
480                  rcphi (144,108,2) = 43.0
481                  rclam (144,108,3) = -1.5 
482                  rcphi (144,108,3) = 42.0
483               ENDIF
484
485               WHERE (umask(:,:,1) > 0.5 )
486                  mask(:,:) = 0
487               ELSE WHERE
488                  mask(:,:) = 1
489               END WHERE
490
491               area = e1u * e2u
492
493            ELSE IF ( i_grid == 3 ) THEN
494
495               ! --------------------------------------------------------
496               ! ... Write the grid info for v points
497               ! --------------------------------------------------------
498
499               point_name = 'opav'
500
501               glam_b = glamv
502               gphi_b = gphiv
503
504               DO ji = 1, jpi
505                  DO jj = 1, jpj
506
507                     im1 = ji-1
508                     jp1 = jj+1
509                     IF (ji == 1) im1 = jpiglo-2
510                     IF (jj == jpjglo) jp1 = jj
511
512                     rclam(ji,jj,1) = glamu(ji,jp1)
513                     rclam(ji,jj,2) = glamu(im1,jp1)
514                     rclam(ji,jj,3) = glamu(im1,jj)
515                     rclam(ji,jj,4) = glamu(ji,jj)
516
517                     rcphi(ji,jj,1) = gphiu(ji,jp1)
518                     rcphi(ji,jj,2) = gphiu(im1,jp1)
519                     rcphi(ji,jj,3) = gphiu(im1,jj)
520                     rcphi(ji,jj,4) = gphiu(ji,jj)
521
522                  END DO
523               END DO
524
525               ! Correction of one (land) grid cell of the orca2 grid.
526               ! It was causing problems with the SCRIP interpolation.
527
528               IF (jpiglo == 182 .AND. jpjglo == 149) THEN
529                  rclam(145,105,2) = -1.0 
530                  rcphi(145,105,2) = 40.5
531               ENDIF
532
533               WHERE (vmask(:,:,1) > 0.5 )
534                  mask(:,:) = 0
535               ELSE WHERE
536                  mask(:,:) = 1
537               END WHERE
538
539               area = e1v * e2v
540
541            ENDIF ! i_grid
542
543            WHERE (glam_b(:,:) < 0.)
544               glam_b(:,:) = glam_b(:,:) + 360.
545            END WHERE
546            WHERE (glam_b(:,:) > 360.)
547               glam_b(:,:) = glam_b(:,:) - 360.
548            END WHERE
549
550            WHERE (rclam(:,:,:) < 0.)
551               rclam(:,:,:) = rclam(:,:,:) + 360.
552            END WHERE
553            WHERE (rclam(:,:,:) > 360.)
554               rclam(:,:,:) = rclam(:,:,:) - 360.
555            END WHERE
556
557            mask(:,jpjglo)=1
558
559            CALL prism_write_grid   ( point_name, nx, ny, glam_b, gphi_b ) 
560            CALL prism_write_corner ( point_name, nx, ny, nc, rclam, rcphi )
561            CALL prism_write_mask   ( point_name, nx, ny, mask )
562            CALL prism_write_area   ( point_name, nx, ny, area )
563
564         END DO ! i_grid
565
566         CALL prism_terminate_grids_writing ()
567
568      ENDIF ! localRank == localRoot .and. write_grid == 1
569
570      ! -----------------------------------------------------------------
571      ! ... Define the partition
572      ! -----------------------------------------------------------------
573
574      IF ( rootexchg ) THEN
575
576         paral(1) = 2              ! box partitioning
577         paral(2) = 0              ! NEMO lower left corner global offset   
578         paral(3) = jpiglo         ! local extent in i
579         paral(4) = jpjglo         ! local extent in j
580         paral(5) = jpiglo         ! global extent in x
581
582         range(1) = nimpp-1+nldi   ! global start in i
583         range(2) = nlei-nldi+1    ! local size in i of valid region
584         range(3) = njmpp-1+nldj   ! global start in j
585         range(4) = nlej-nldj+1    ! local size in j of valid region
586         range(5) = range(2) &
587                  * range(4)       ! local horizontal size
588
589         IF(ln_ctl) THEN
590         write(numout,*) ' rootexchg: range(1:5)', range
591         ENDIF
592
593         !
594         ! Collect ranges from all NEMO procs on the local root process
595         !
596         CALL mpi_gather(range,  5, MPI_INTEGER, &
597                         ranges, 5, MPI_INTEGER, localRoot, localComm, ierror)
598
599         IF ( localRank == localRoot ) THEN
600
601            maxlen = maxval(ranges(5,:))
602           
603            ALLOCATE(buffer(1:maxlen), stat = ierror)
604            IF (ierror > 0) THEN
605               CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating buffer')
606               RETURN
607            ENDIF
608
609          ENDIF
610
611      ELSE
612
613         paral(1) = 2                  ! box partitioning
614!2dtest         paral(2) = jpiglo           &
615!2dtest                  * (nldj-1+njmpp-1) &
616!2dtest                  + (nldi-1+nimpp-1)   ! NEMO lower left corner global offset   
617         paral(2) = jpiglo &
618                  * (nldj-1+njmpp-1)   ! NEMO lower left corner global offset   
619         paral(3) = nlei-nldi+1        ! local extent in i
620         paral(4) = nlej-nldj+1        ! local extent in j
621         paral(5) = jpiglo             ! global extent in x
622
623         IF(ln_ctl) THEN
624            print*, ' multiexchg: paral (1:5)', paral
625            print*, ' multiexchg: jpi, jpj =', jpi, jpj
626            print*, ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp
627            print*, ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp
628         ENDIF
629
630         IF ( paral(3) /= nlei-nldi+1 ) THEN
631              print*, 'WARNING!!! in cpl_oasis3 - cpl_prism_define'
632              print*, 'cpl_prism_define: local extend in i is ', paral(3), ' should equal ', nlei-nldi+1
633         ENDIF
634         IF ( paral(4) /= nlej-nldj+1 ) THEN
635              print*, 'WARNING!!! in cpl_oasis3 - cpl_prism_define'
636              print*, 'cpl_prism_define: local extend in j is ', paral(4), ' should equal ', nlej-nldj+1
637         ENDIF
638
639      ENDIF
640
641      IF ( commRank ) &
642      CALL prism_def_partition_proto ( part_id, paral, ierror )
643
644      grid_id(1)= part_id
645
646      !------------------------------------------------------------------
647      ! 3rd Declare the transient variables
648      !------------------------------------------------------------------
649      !
650      ! ... Define symbolic names for the transient fields send by the ocean
651      !     These must be identical to the names specified in the SMIOC file.
652      !
653      cpl_send( 1)='SSTOCEAN' ! sea surface temperature              -> sst_io
654      cpl_send( 2)='SICOCEAN' ! sea ice area fraction                -> 1.-frld
655#if defined key_cpl_albedo
656      cpl_send( 3)='STIOCEAN' ! surface temperature over sea ice     -> tn_ice
657      cpl_send( 4)='SAIOCEAN' ! albedo over sea ice                  -> alb_ice
658#else
659      cpl_send( 3)='SITOCEAN' ! sea ice thickness                    -> hicif (only 1 layer available!)
660      cpl_send( 4)='SNTOCEAN' ! surface snow thickness over sea ice  -> hsnif
661#endif
662#if defined key_cpl_ocevel
663      cpl_send( 5)='SUNOCEAN' ! U-velocity                           -> un
664      cpl_send( 6)='SVNOCEAN' ! V-velocity                           -> vn
665#endif
666      !
667      ! ...  Define symbolic names for transient fields received by the ocean.
668      !      These must be identical to the names specified in the SMIOC file.
669      !
670      ! ...  a) U-Grid fields
671      !
672      cpl_recv( 1)='TXWOCEWU' ! weighted surface downward eastward stress
673      cpl_recv( 2)='TYWOCEWU' ! weighted surface downward northward stress
674      cpl_recv( 3)='TXIOCEWU' ! weighted surface downward eastward stress over ice
675      cpl_recv( 4)='TYIOCEWU' ! weighted surface downward northward stress over ice
676      !
677      ! ...  a) V-Grid fields
678      !
679      cpl_recv( 5)='TXWOCEWV' ! weighted surface downward eastward stress
680      cpl_recv( 6)='TYWOCEWV' ! weighted surface downward northward stress
681      cpl_recv( 7)='TXIOCEWV' ! weighted surface downward eastward stress over ice
682      cpl_recv( 8)='TYIOCEWV' ! weighted surface downward northward stress over ice
683      !
684      ! ...  a) T-Grid fields
685      !
686      cpl_recv( 9)='FRWOCEPE' ! P-E over water                               -> zpew
687      cpl_recv(10)='FRIOCEPE' ! P-E over ice                                 -> zpei
688      cpl_recv(11)='FRROCESN' ! surface downward snow fall                   -> zpsol
689      cpl_recv(12)='FRIOCEEV' ! surface upward snow flux where sea ice       -> zevice
690
691      cpl_recv(13)='QSWOCESR' ! surface net downward shortwave flux          -> qsr_oce
692      cpl_recv(14)='QSWOCENS' ! surface downward non-solar heat flux in air  -> qnsr_oce
693      cpl_recv(15)='QSIOCESR' ! solar heat flux on sea ice                   -> qsr_ice
694      cpl_recv(16)='QSIOCENS' ! non-solar heat flux on sea ice               -> qnsr_ice
695      cpl_recv(17)='QSIOCEDQ' ! non-solar heat flux derivative               -> dqns_ice
696
697#ifdef key_cpl_discharge
698      cpl_recv(18)='FRWOCEIS' ! ice discharge into ocean                     -> calving
699      cpl_recv(19)='FRWOCERD' ! river discharge into ocean                   -> zrunriv
700      cpl_recv(20)='FRWOCECD' ! continental discharge into ocean             -> zruncot
701#endif
702      !
703      ! data_type has to be PRISM_REAL as PRISM_DOUBLE is not supported.
704      ! For exchange of double precision fields the OASIS3 has to be compiled
705      ! with use_realtype_single. (see OASIS3 User Guide prism_2-4, 5th Ed.,
706      ! p. 13 and p. 53 for further explanation.)
707      !
708      data_type = PRISM_REAL
709
710      nodim(1) = 3 ! check
711      nodim(2) = 0
712
713      !
714      ! ... Define the shape for the area that excludes the halo
715      !     For serial configuration (key_mpp_mpi not being active)
716      !     nl* is set to the global values 1 and jp*glo.
717      !
718      IF ( rootexchg ) THEN
719         shape(1,1) = 1
720         shape(2,1) = jpiglo
721         shape(1,2) = 1
722         shape(2,2) = jpjglo
723         shape(1,3) = 1
724         shape(2,3) = 1
725       ELSE
726         shape(1,1) = 1
727         shape(2,1) = nlei-nldi+1 ! jpi
728         shape(1,2) = 1
729         shape(2,2) = nlej-nldj+1 ! jpj
730         shape(1,3) = 1
731         shape(2,3) = 1
732      ENDIF
733      !
734      ! -----------------------------------------------------------------
735      ! ... Allocate memory for data exchange
736      ! -----------------------------------------------------------------
737      !
738      ALLOCATE(exfld(shape(1,1):shape(2,1),shape(1,2):shape(2,2)), stat = ierror)
739      IF (ierror > 0) THEN
740         CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in allocating exfld')
741         RETURN
742      ENDIF
743      !
744      ! ... Announce send variables, all on T points.
745      !
746      info = PRISM_Out
747      !
748
749      IF ( commRank ) THEN
750
751         DO ji = 1, nsend
752            !        if ( ji == 2 ) ; then ; nodim(2) = 2 ; else ; nodim(2) = 0 ; endif
753            CALL prism_def_var_proto (send_id(ji), cpl_send(ji), grid_id(1), &
754                 nodim, info, shape, data_type, ierror)
755            IF ( ierror /= PRISM_Ok ) THEN
756               PRINT *, 'Failed to define transient ', ji, TRIM(cpl_send(ji))
757               CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var')
758            ENDIF
759         ENDDO
760         !
761         nodim(1) = 3 ! check
762         nodim(2) = 0
763         !
764         ! ... Announce recv variables.
765         !
766         info = PRISM_In
767         !
768         ! ... a) on U points
769         !
770         DO ji = 1, 4
771            CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), &
772                 nodim, info, shape, data_type, ierror)
773            IF ( ierror /= PRISM_Ok ) THEN
774               PRINT *, 'Failed to define transient ', ji, TRIM(cpl_recv(ji))
775               CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var')
776            ENDIF
777         ENDDO
778         !
779         ! ... b) on V points
780         !
781         DO ji = 5, 8
782            CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), &
783                 nodim, info, shape, data_type, ierror)
784            IF ( ierror /= PRISM_Ok ) THEN
785               PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji))
786               CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var')
787            ENDIF
788         ENDDO
789         !
790         ! ... c) on T points
791         !
792         DO ji = 9, nrecv
793            CALL prism_def_var_proto (recv_id(ji), cpl_recv(ji), grid_id(1), &
794                 nodim, info, shape, data_type, ierror)
795            IF ( ierror /= PRISM_Ok ) THEN
796               PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji))
797               CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_def_var')
798            ENDIF
799         ENDDO
800
801      ENDIF ! commRank
802
803      !------------------------------------------------------------------
804      ! 4th End of definition phase
805      !------------------------------------------------------------------
806
807      IF ( commRank ) THEN
808         CALL prism_enddef_proto(ierror)
809         IF ( ierror /= PRISM_Ok ) &
810              CALL prism_abort_proto ( comp_id, 'cpl_prism_define', 'Failure in prism_enddef')
811      ENDIF
812
813   END SUBROUTINE cpl_prism_define
814
815
816
817   SUBROUTINE cpl_prism_send( var_id, date, data_array, info )
818
819      IMPLICIT NONE
820
821      !!---------------------------------------------------------------------
822      !!              ***  ROUTINE cpl_prism_send  ***
823      !!
824      !! ** Purpose : - At each coupling time-step,this routine sends fields
825      !!      like sst or ice cover to the coupler or remote application.
826      !!----------------------------------------------------------------------
827      !! * Arguments
828      !!
829      INTEGER, INTENT( IN )  :: var_id    ! variable Id
830      INTEGER, INTENT( OUT ) :: info      ! OASIS3 info argument
831      INTEGER, INTENT( IN )  :: date      ! ocean time-step in seconds
832      REAL(wp)               :: data_array(:,:)
833      !!
834      !! * Local declarations
835      !!
836#if defined key_mpp_mpi
837      REAL(wp)               :: global_array(jpiglo,jpjglo)
838      !
839!mpi  INTEGER                :: status(MPI_STATUS_SIZE)
840!mpi  INTEGER                :: type       ! MPI data type
841      INTEGER                :: request    ! MPI isend request
842      INTEGER                :: ji, jj, jn ! local loop indicees
843#else
844      INTEGER                :: ji
845#endif
846      !!
847      !!--------------------------------------------------------------------
848      !!
849
850#if defined key_mpp_mpi
851
852      request = 0
853
854      IF ( rootexchg ) THEN
855         !
856!mpi     IF ( wp == 4 ) type = MPI_REAL
857!mpi     IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION
858         !
859         ! collect data on the local root process
860         !
861
862         if ( var_id == 1 .and. localRank == localRoot .and. ln_ctl )  then
863             do ji = 0, localSize-1
864                WRITE(numout,*) ' rootexchg: ranges for rank ', ji, ' are ', ranges(:,ji) 
865             enddo
866         endif
867
868         IF ( localRank /= localRoot ) THEN
869
870            DO jj = nldj, nlej
871               DO ji = nldi, nlei
872                  exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj)
873               ENDDO
874            ENDDO
875
876!mpi        CALL mpi_send(exfld, range(5), type, localRoot, localRank, localComm, ierror)
877            CALL mppsend (localRank, exfld, range(5), localRoot, request) 
878
879            if ( var_id == 1 .and. ln_ctl )  then
880               WRITE(numout,*) ' rootexchg: This is process       ', localRank
881               WRITE(numout,*) ' rootexchg: We have a range of    ', range 
882!               WRITE(numout,*) ' rootexchg: We got SST to process ', data_array
883            endif
884
885         ENDIF
886
887         IF ( localRank == localRoot ) THEN
888
889            DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1
890               DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1
891                  global_array(ji,jj) = data_array(ji,jj) ! workaround
892               ENDDO
893            ENDDO
894
895            DO jn = 1, localSize-1
896
897!mpi           CALL mpi_recv(buffer, ranges(5,jn), type, localRoot, jn, localComm, status, ierror)
898               CALL mpprecv(jn, buffer, ranges(5,jn))
899
900               if ( var_id == 1 .and. ln_ctl )  then
901                   WRITE(numout,*) ' rootexchg: Handling data from process ', jn
902!                   WRITE(numout,*) ' rootexchg: We got SST to process      ', buffer
903               endif
904
905
906               DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1
907                  DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1
908                     global_array(ji,jj) = buffer((jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1)
909                  ENDDO
910               ENDDO
911
912            ENDDO
913
914            CALL prism_put_proto ( var_id, date, global_array, info )
915
916         ENDIF
917
918      ELSE
919
920         DO jj = nldj, nlej
921            DO ji = nldi, nlei
922               exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj)
923            ENDDO
924         ENDDO
925
926         CALL prism_put_proto ( var_id, date, exfld, info )
927
928      ENDIF
929
930#else
931
932      !
933      ! send local data from every process to OASIS3
934      !
935      IF ( commRank ) &
936      CALL prism_put_proto ( var_id, date, data_array, info )
937
938#endif
939
940      IF ( commRank ) THEN
941
942         IF (ln_ctl .and. lwp) THEN       
943
944            IF ( info == PRISM_Sent     .OR. &
945                 info == PRISM_ToRest   .OR. &
946                 info == PRISM_SentOut  .OR. &
947                 info == PRISM_ToRestOut       ) THEN
948               WRITE(numout,*) '****************'
949               DO ji = 1, nsend
950                  IF (var_id == send_id(ji) ) THEN
951                     WRITE(numout,*) 'prism_put_proto: Outgoing ', cpl_send(ji)
952                     EXIT
953                  ENDIF
954               ENDDO
955               WRITE(numout,*) 'prism_put_proto: var_id ', var_id
956               WRITE(numout,*) 'prism_put_proto:   date ', date
957               WRITE(numout,*) 'prism_put_proto:   info ', info
958               WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array)
959               WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array)
960               WRITE(numout,*) '     -     Sum value is ', SUM(data_array)
961               WRITE(numout,*) '****************'
962            ENDIF
963
964         ENDIF
965
966      ENDIF
967
968   END SUBROUTINE cpl_prism_send
969
970
971
972   SUBROUTINE cpl_prism_recv( var_id, date, data_array, info )
973
974      IMPLICIT NONE
975
976      !!---------------------------------------------------------------------
977      !!              ***  ROUTINE cpl_prism_recv  ***
978      !!
979      !! ** Purpose : - At each coupling time-step,this routine receives fields
980      !!      like stresses and fluxes from the coupler or remote application.
981      !!----------------------------------------------------------------------
982      !! * Arguments
983      !!
984      INTEGER, INTENT( IN )  :: var_id    ! variable Id
985      INTEGER, INTENT( OUT ) :: info      ! variable Id
986      INTEGER, INTENT( IN )  :: date      ! ocean time-step in seconds
987      REAL(wp),INTENT( OUT ) :: data_array(:,:)
988      !!
989      !! * Local declarations
990      !!
991#if defined key_mpp_mpi
992      REAL(wp)               :: global_array(jpiglo,jpjglo)
993      !
994!      LOGICAL                :: action = .false.
995      LOGICAL                :: action
996!mpi  INTEGER                :: status(MPI_STATUS_SIZE)
997!mpi  INTEGER                :: type       ! MPI data type
998      INTEGER                :: request    ! MPI isend request
999      INTEGER                :: ji, jj, jn ! local loop indices
1000#else
1001      INTEGER                :: ji
1002#endif
1003      !!
1004      !!--------------------------------------------------------------------
1005      !!
1006#ifdef key_mpp_mpi
1007      action = .false.
1008      request = 0
1009
1010      IF ( rootexchg ) THEN
1011         !
1012         ! receive data from OASIS3 on local root
1013         !
1014         IF ( commRank ) &
1015              CALL prism_get_proto ( var_id, date, global_array, info )
1016
1017         CALL MPI_BCAST ( info, 1, MPI_INTEGER, localRoot, localComm, ierror )
1018
1019      ELSE
1020         !
1021         ! receive local data from OASIS3 on every process
1022         !
1023         CALL prism_get_proto ( var_id, date, exfld, info )
1024
1025      ENDIF
1026
1027      IF ( info == PRISM_Recvd        .OR. &
1028           info == PRISM_FromRest     .OR. &
1029           info == PRISM_RecvOut      .OR. &
1030           info == PRISM_FromRestOut ) action = .true.
1031
1032      IF (ln_ctl .and. lwp) THEN       
1033         WRITE(numout,*) "info", info, var_id
1034         WRITE(numout,*) "date", date, var_id
1035         WRITE(numout,*) "action", action, var_id
1036      ENDIF
1037
1038      IF ( rootexchg .and. action ) THEN
1039         !
1040!mpi     IF ( wp == 4 ) type = MPI_REAL
1041!mpi     IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION
1042         !
1043         ! distribute data to processes
1044         !
1045         IF ( localRank == localRoot ) THEN
1046
1047            DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1
1048               DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1
1049                  exfld(ji-ranges(1,localRoot)+1,jj-ranges(3,localRoot)+1) = global_array(ji,jj)
1050               ENDDO
1051            ENDDO
1052
1053            DO jn = 1, localSize-1
1054
1055               DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1
1056                  DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1
1057                     buffer((jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1) = global_array(ji,jj)
1058                  ENDDO
1059               ENDDO
1060
1061!mpi           CALL mpi_send(buffer, ranges(5,jn), type, jn, jn, localComm, ierror)
1062               CALL mppsend (jn, buffer, ranges(5,jn), jn, request) 
1063
1064            ENDDO
1065
1066         ENDIF
1067
1068         IF ( localRank /= localRoot ) THEN
1069!mpi         CALL mpi_recv(exfld, range(5), type, localRoot, localRank, localComm, status, ierror)
1070             CALL mpprecv(localRank, exfld, range(5))
1071         ENDIF
1072
1073      ENDIF
1074
1075      IF ( action ) THEN
1076
1077         data_array = 0.0
1078
1079         DO jj = nldj, nlej
1080            DO ji = nldi, nlei
1081               data_array(ji,jj)=exfld(ji-nldi+1,jj-nldj+1)
1082            ENDDO
1083         ENDDO
1084
1085         IF (ln_ctl .and. lwp) THEN       
1086            WRITE(numout,*) '****************'
1087            DO ji = 1, nrecv
1088               IF (var_id == recv_id(ji) ) THEN
1089                  WRITE(numout,*) 'prism_get_proto: Incoming ', cpl_recv(ji)
1090                  EXIT
1091               ENDIF
1092            ENDDO
1093            WRITE(numout,*) 'prism_get_proto: var_id ', var_id
1094            WRITE(numout,*) 'prism_get_proto:   date ', date
1095            WRITE(numout,*) 'prism_get_proto:   info ', info
1096            WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array)
1097            WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array)
1098            WRITE(numout,*) '     -     Sum value is ', SUM(data_array)
1099            WRITE(numout,*) '****************'
1100         ENDIF
1101
1102      ENDIF
1103#else
1104      CALL prism_get_proto ( var_id, date, exfld, info)
1105     
1106      IF (info == PRISM_Recvd        .OR. &
1107          info == PRISM_FromRest     .OR. &
1108          info == PRISM_RecvOut      .OR. &
1109          info == PRISM_FromRestOut )      THEN
1110             data_array = exfld
1111
1112         IF (ln_ctl .and. lwp ) THEN       
1113            WRITE(numout,*) '****************'
1114            DO ji = 1, nrecv
1115               IF (var_id == recv_id(ji) ) THEN
1116                  WRITE(numout,*) 'prism_get_proto: Incoming ', cpl_recv(ji)
1117                  EXIT
1118               ENDIF
1119            ENDDO
1120            WRITE(numout,*) 'prism_get_proto: var_id ', var_id
1121            WRITE(numout,*) 'prism_get_proto:   date ', date
1122            WRITE(numout,*) 'prism_get_proto:   info ', info
1123            WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array)
1124            WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array)
1125            WRITE(numout,*) '     -     Sum value is ', SUM(data_array)
1126            WRITE(numout,*) '****************'
1127         ENDIF
1128
1129       ENDIF
1130#endif
1131
1132   END SUBROUTINE cpl_prism_recv
1133
1134
1135
1136   SUBROUTINE cpl_prism_finalize
1137
1138      IMPLICIT NONE
1139
1140      !!---------------------------------------------------------------------
1141      !!              ***  ROUTINE cpl_prism_finalize  ***
1142      !!
1143      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
1144      !!      called explicitly before cpl_prism_init it will also close
1145      !!      MPI communication.
1146      !!----------------------------------------------------------------------
1147
1148      DEALLOCATE(exfld)
1149
1150      if ( prism_was_initialized ) then
1151
1152         if ( prism_was_terminated ) then
1153            print *, 'prism has already been terminated.'
1154         else
1155            call prism_terminate_proto ( ierror )
1156            prism_was_terminated = .true.
1157         endif
1158
1159      else
1160
1161         print *, 'Initialize prism before terminating it.'
1162
1163      endif
1164
1165
1166   END SUBROUTINE cpl_prism_finalize
1167
1168#endif
1169
1170END MODULE cpl_oasis3
Note: See TracBrowser for help on using the repository browser.