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/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90 @ 11101

Last change on this file since 11101 was 11101, checked in by frrh, 5 years ago

Merge changes from Met Office GMED ticket 450 to reduce unnecessary
text output from NEMO.
This output, which is typically not switchable, is rarely of interest
in normal (non-debugging) runs and simply redunantley consumes extra
file space.
Further, the presence of this text output has been shown to
significantly degrade performance of models which are run during
Met Office HPC RAID (disk) checks.
The new code introduces switches which are configurable via the
changes made in the associated Met Office MOCI ticket 399.

File size: 35.5 KB
RevLine 
[532]1MODULE cpl_oasis3
2   !!======================================================================
3   !!                    ***  MODULE cpl_oasis  ***
[4990]4   !! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT
[532]5   !!=====================================================================
6   !! History :   
[2715]7   !!   9.0  !  04-06  (R. Redler, NEC Laboratories Europe, Germany) Original code
8   !!   " "  !  04-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Germany) revision
[532]9   !!   " "  !  04-11  (V. Gayler, MPI M&D) Grid writing
10   !!   " "  !  05-08  (R. Redler, W. Park) frld initialization, paral(2) revision
11   !!   " "  !  05-09  (R. Redler) extended to allow for communication over root only
12   !!   " "  !  06-01  (W. Park) modification of physical part
13   !!   " "  !  06-02  (R. Redler, W. Park) buffer array fix for root exchange
[3294]14   !!   3.4  !  11-11  (C. Harris) Changes to allow mutiple category fields
[532]15   !!----------------------------------------------------------------------
16   !!----------------------------------------------------------------------
[5407]17   !!   'key_oasis3'                    coupled Ocean/Atmosphere via OASIS3-MCT
18   !!   'key_oa3mct_v3'                 to be added for OASIS3-MCT version 3
[532]19   !!----------------------------------------------------------------------
[4990]20   !!   cpl_init     : initialization of coupled mode communication
21   !!   cpl_define   : definition of grid and fields
22   !!   cpl_snd     : snd out fields in coupled mode
23   !!   cpl_rcv     : receive fields in coupled mode
24   !!   cpl_finalize : finalize the coupled mode communication
[532]25   !!----------------------------------------------------------------------
[4990]26#if defined key_oasis3
27   USE mod_oasis                    ! OASIS3-MCT module
28#endif
[1218]29   USE par_oce                      ! ocean parameters
[10269]30   USE cpl_rnf_1d, ONLY: nn_cpl_river   ! Variables used in 1D river outflow
[532]31   USE dom_oce                      ! ocean space and time domain
32   USE in_out_manager               ! I/O manager
[2715]33   USE lbclnk                       ! ocean lateral boundary conditions (or mpp link)
[8280]34   
[532]35   IMPLICIT NONE
[1218]36   PRIVATE
[10269]37   
38#if ! defined key_oasis3
39   ! Dummy interface to oasis_get if not using oasis
40   INTERFACE oasis_get
41      MODULE PROCEDURE oasis_get_1d, oasis_get_2d
42   END INTERFACE
43#endif
[532]44
[4990]45   PUBLIC   cpl_init
46   PUBLIC   cpl_define
47   PUBLIC   cpl_snd
48   PUBLIC   cpl_rcv
[10269]49   PUBLIC   cpl_rcv_1d
[4990]50   PUBLIC   cpl_freq
51   PUBLIC   cpl_finalize
[8280]52#if defined key_mpp_mpi
53   INCLUDE 'mpif.h'
54#endif
55   
56   INTEGER, PARAMETER         :: localRoot  = 0
57   LOGICAL                    :: commRank            ! true for ranks doing OASIS communication
58#if defined key_cpl_rootexchg
59   LOGICAL                    :: rootexchg =.true.   ! logical switch
60#else
61   LOGICAL                    :: rootexchg =.false.  ! logical switch
62#endif
[2715]63
64   INTEGER, PUBLIC            ::   OASIS_Rcv  = 1    !: return code if received field
65   INTEGER, PUBLIC            ::   OASIS_idle = 0    !: return code if nothing done by oasis
[4990]66   INTEGER                    ::   ncomp_id          ! id returned by oasis_init_comp
[2715]67   INTEGER                    ::   nerror            ! return error code
[4990]68#if ! defined key_oasis3
69   ! OASIS Variables not used. defined only for compilation purpose
70   INTEGER                    ::   OASIS_Out         = -1
71   INTEGER                    ::   OASIS_REAL        = -1
72   INTEGER                    ::   OASIS_Ok          = -1
73   INTEGER                    ::   OASIS_In          = -1
74   INTEGER                    ::   OASIS_Sent        = -1
75   INTEGER                    ::   OASIS_SentOut     = -1
76   INTEGER                    ::   OASIS_ToRest      = -1
77   INTEGER                    ::   OASIS_ToRestOut   = -1
78   INTEGER                    ::   OASIS_Recvd       = -1
79   INTEGER                    ::   OASIS_RecvOut     = -1
80   INTEGER                    ::   OASIS_FromRest    = -1
81   INTEGER                    ::   OASIS_FromRestOut = -1
82#endif
[2715]83
[5407]84   INTEGER                    ::   nrcv         ! total number of fields received
85   INTEGER                    ::   nsnd         ! total number of fields sent
86   INTEGER                    ::   ncplmodel    ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
87   INTEGER, PUBLIC, PARAMETER ::   nmaxfld=50   ! Maximum number of coupling fields
[4990]88   INTEGER, PUBLIC, PARAMETER ::   nmaxcat=5    ! Maximum number of coupling fields
89   INTEGER, PUBLIC, PARAMETER ::   nmaxcpl=5    ! Maximum number of coupling fields
[1218]90   
[3294]91   TYPE, PUBLIC ::   FLD_CPL               !: Type for coupling field information
92      LOGICAL               ::   laction   ! To be coupled or not
93      CHARACTER(len = 8)    ::   clname    ! Name of the coupling field   
94      CHARACTER(len = 1)    ::   clgrid    ! Grid type 
95      REAL(wp)              ::   nsgn      ! Control of the sign change
[4990]96      INTEGER, DIMENSION(nmaxcat,nmaxcpl) ::   nid   ! Id of the field (no more than 9 categories and 9 extrena models)
[3294]97      INTEGER               ::   nct       ! Number of categories in field
[4990]98      INTEGER               ::   ncplmodel ! Maximum number of models to/from which this variable may be sent/received
[10269]99      INTEGER               ::   dimensions ! Number of dimensions of coupling field
[1218]100   END TYPE FLD_CPL
[532]101
[2715]102   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC ::   srcv, ssnd   !: Coupling fields
[532]103
[2715]104   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   exfld   ! Temporary buffer for receiving
[8280]105   INTEGER, PUBLIC :: localComm 
106     
[532]107   !!----------------------------------------------------------------------
[2528]108   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
109   !! $Id$
[2715]110   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[532]111   !!----------------------------------------------------------------------
112CONTAINS
113
[5407]114   SUBROUTINE cpl_init( cd_modname, kl_comm )
[532]115      !!-------------------------------------------------------------------
[4990]116      !!             ***  ROUTINE cpl_init  ***
[532]117      !!
118      !! ** Purpose :   Initialize coupled mode communication for ocean
119      !!    exchange between AGCM, OGCM and COUPLER. (OASIS3 software)
120      !!
121      !! ** Method  :   OASIS3 MPI communication
122      !!--------------------------------------------------------------------
[5407]123      CHARACTER(len = *), INTENT(in) ::   cd_modname   ! model name as set in namcouple file
124      INTEGER          , INTENT(out) ::   kl_comm      ! local communicator of the model
[1226]125      !!--------------------------------------------------------------------
[1218]126
[1579]127      ! WARNING: No write in numout in this routine
128      !============================================
129
[532]130      !------------------------------------------------------------------
[4990]131      ! 1st Initialize the OASIS system for the application
[532]132      !------------------------------------------------------------------
[5407]133      CALL oasis_init_comp ( ncomp_id, TRIM(cd_modname), nerror )
[4990]134      IF ( nerror /= OASIS_Ok ) &
135         CALL oasis_abort (ncomp_id, 'cpl_init', 'Failure in oasis_init_comp')
[532]136
137      !------------------------------------------------------------------
138      ! 3rd Get an MPI communicator for OPA local communication
139      !------------------------------------------------------------------
140
[4990]141      CALL oasis_get_localcomm ( kl_comm, nerror )
142      IF ( nerror /= OASIS_Ok ) &
143         CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' )
[8280]144      localComm = kl_comm 
[2715]145      !
[4990]146   END SUBROUTINE cpl_init
[532]147
148
[4990]149   SUBROUTINE cpl_define( krcv, ksnd, kcplmodel )
[532]150      !!-------------------------------------------------------------------
[4990]151      !!             ***  ROUTINE cpl_define  ***
[532]152      !!
153      !! ** Purpose :   Define grid and field information for ocean
154      !!    exchange between AGCM, OGCM and COUPLER. (OASIS3 software)
155      !!
156      !! ** Method  :   OASIS3 MPI communication
157      !!--------------------------------------------------------------------
[2715]158      INTEGER, INTENT(in) ::   krcv, ksnd     ! Number of received and sent coupling fields
[4990]159      INTEGER, INTENT(in) ::   kcplmodel      ! Maximum number of models to/from which NEMO is potentialy sending/receiving data
[1226]160      !
[2715]161      INTEGER :: id_part
[10269]162      INTEGER :: id_part_0d     ! Partition for 0d fields
163      INTEGER :: id_part_rnf_1d ! Partition for 1d river outflow fields
164      INTEGER :: id_part_temp   ! Temperary partition used to choose either 0d or 1d partitions
[2715]165      INTEGER :: paral(5)       ! OASIS3 box partition
[10269]166      INTEGER :: ishape(4)      ! Shape of 2D arrays passed to PSMILe.
[10159]167                                ! Redundant from OASIS3-MCT vn4.0 onwards but required
[10269]168                                ! to satisfy interface and for backward compatibility.
169      INTEGER :: ishape0d1d(2)  ! Shape of 0D or 1D arrays passed to PSMILe.
[10159]170      INTEGER :: var_nodims(2)  ! Number of coupling field dimensions.
171                                ! var_nodims(1) is redundant from OASIS3-MCT vn4.0 onwards
172                                ! but retained for backward compatibility.
173                                ! var_nodims(2) is the number of fields in a bundle
174                                ! or 1 for unbundled fields (bundles are not yet catered for
175                                ! in NEMO hence we default to 1). 
[4990]176      INTEGER :: ji,jc,jm       ! local loop indicees
177      CHARACTER(LEN=64) :: zclname
178      CHARACTER(LEN=2) :: cli2
[532]179      !!--------------------------------------------------------------------
[1218]180
[532]181      IF(lwp) WRITE(numout,*)
[4990]182      IF(lwp) WRITE(numout,*) 'cpl_define : initialization in coupled ocean/atmosphere case'
[532]183      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
184      IF(lwp) WRITE(numout,*)
[11101]185      IF(lflush) CALL flush(numout)
[532]186
[5407]187      ncplmodel = kcplmodel
[4990]188      IF( kcplmodel > nmaxcpl ) THEN
[5407]189         CALL oasis_abort ( ncomp_id, 'cpl_define', 'ncplmodel is larger than nmaxcpl, increase nmaxcpl')   ;   RETURN
[4990]190      ENDIF
[5407]191
192      nrcv = krcv
193      IF( nrcv > nmaxfld ) THEN
194         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nrcv is larger than nmaxfld, increase nmaxfld')   ;   RETURN
195      ENDIF
196
197      nsnd = ksnd
198      IF( nsnd > nmaxfld ) THEN
199         CALL oasis_abort ( ncomp_id, 'cpl_define', 'nsnd is larger than nmaxfld, increase nmaxfld')   ;   RETURN
200      ENDIF
201
[532]202      !
203      ! ... Define the shape for the area that excludes the halo
204      !     For serial configuration (key_mpp_mpi not being active)
205      !     nl* is set to the global values 1 and jp*glo.
206      !
[10159]207      ishape(1) = 1
208      ishape(2) = nlei-nldi+1
209      ishape(3) = 1
210      ishape(4) = nlej-nldj+1
211
[10269]212      ishape0d1d(1) = 0
213      ishape0d1d(2) = 0
[10159]214
[532]215      !
216      ! ... Allocate memory for data exchange
217      !
[1218]218      ALLOCATE(exfld(nlei-nldi+1, nlej-nldj+1), stat = nerror)
[2715]219      IF( nerror > 0 ) THEN
[4990]220         CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld')   ;   RETURN
[8280]221      ENDIF     
[532]222      !
[1218]223      ! -----------------------------------------------------------------
224      ! ... Define the partition
225      ! -----------------------------------------------------------------
[8280]226           
[1218]227      paral(1) = 2                                              ! box partitioning
228      paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1)   ! NEMO lower left corner global offset   
229      paral(3) = nlei-nldi+1                                    ! local extent in i
230      paral(4) = nlej-nldj+1                                    ! local extent in j
231      paral(5) = jpiglo                                         ! global extent in x
232     
233      IF( ln_ctl ) THEN
234         WRITE(numout,*) ' multiexchg: paral (1:5)', paral
235         WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj
236         WRITE(numout,*) ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp
237         WRITE(numout,*) ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp
[11101]238         IF(lflush) CALL flush(numout)
[1218]239      ENDIF
240     
[8280]241      CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo)
[10269]242
243      ! A special partition is needed for 0D fields
244     
245      paral(1) = 0                                       ! serial partitioning
246      paral(2) = 0   
247      IF ( nproc == 0) THEN
248         paral(3) = 1                   ! Size of array to couple (scalar)
249      ELSE
250         paral(3) = 0                   ! Dummy size for PE's not involved
251      END IF
252      paral(4) = 0
253      paral(5) = 0
254       
255      CALL oasis_def_partition ( id_part_0d, paral, nerror, 1 )
256
257      ! Another partition is needed for 1D river routing fields
258     
259      paral(1) = 0                                       ! serial partitioning
260      paral(2) = 0   
261      IF ( nproc == 0) THEN
262         paral(3) = nn_cpl_river                   ! Size of array to couple (vector)
263      ELSE
264         paral(3) = 0                   ! Dummy size for PE's not involved
265      END IF
266      paral(4) = 0
267      paral(5) = 0
268
269
270      CALL oasis_def_partition ( id_part_rnf_1d, paral, nerror, nn_cpl_river )
271 
[532]272      !
[1218]273      ! ... Announce send variables.
[532]274      !
[4990]275      ssnd(:)%ncplmodel = kcplmodel
276      !
[1226]277      DO ji = 1, ksnd
[4990]278         IF ( ssnd(ji)%laction ) THEN
279
280            IF( ssnd(ji)%nct > nmaxcat ) THEN
281               CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '//   &
282                  &              TRIM(ssnd(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' )
283               RETURN
284            ENDIF
285           
[3294]286            DO jc = 1, ssnd(ji)%nct
[4990]287               DO jm = 1, kcplmodel
288
289                  IF ( ssnd(ji)%nct .GT. 1 ) THEN
290                     WRITE(cli2,'(i2.2)') jc
291                     zclname = TRIM(ssnd(ji)%clname)//'_cat'//cli2
292                  ELSE
293                     zclname = ssnd(ji)%clname
294                  ENDIF
295                  IF ( kcplmodel  > 1 ) THEN
296                     WRITE(cli2,'(i2.2)') jm
297                     zclname = 'model'//cli2//'_'//TRIM(zclname)
298                  ENDIF
299#if defined key_agrif
300                  IF( agrif_fixed() /= 0 ) THEN
301                     zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname)
302                  END IF
303#endif
304                  IF( ln_ctl ) WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_Out
[10159]305
306                  !
307                  ! ... Set the field dimension and bundle count
308                  var_nodims(1) = 2
309                  var_nodims(2) = 1 ! Modify this value to cater for bundled fields.   
310
311                  CALL oasis_def_var (ssnd(ji)%nid(jc,jm), zclname, id_part   , var_nodims,   &
[4990]312                     &                OASIS_Out          , ishape , OASIS_REAL, nerror )
313                  IF ( nerror /= OASIS_Ok ) THEN
314                     WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname)
315                     CALL oasis_abort ( ssnd(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' )
316                  ENDIF
[11101]317                  IF( ln_ctl) THEN
318                     IF(ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple"
319                     IF(ssnd(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple"
320                     IF(lflush) CALL flush(numout)
321                  ENDIF
[4990]322               END DO
[3294]323            END DO
[1218]324         ENDIF
[8280]325      END DO     
[1218]326      !
327      ! ... Announce received variables.
328      !
[4990]329      srcv(:)%ncplmodel = kcplmodel
330      !
[1226]331      DO ji = 1, krcv
[1218]332         IF ( srcv(ji)%laction ) THEN
[4990]333           
334            IF( srcv(ji)%nct > nmaxcat ) THEN
335               CALL oasis_abort ( ncomp_id, 'cpl_define', 'Number of categories of '//   &
336                  &              TRIM(srcv(ji)%clname)//' is larger than nmaxcat, increase nmaxcat' )
337               RETURN
338            ENDIF
339           
[3294]340            DO jc = 1, srcv(ji)%nct
[4990]341               DO jm = 1, kcplmodel
342                 
343                  IF ( srcv(ji)%nct .GT. 1 ) THEN
344                     WRITE(cli2,'(i2.2)') jc
345                     zclname = TRIM(srcv(ji)%clname)//'_cat'//cli2
346                  ELSE
347                     zclname = srcv(ji)%clname
348                  ENDIF
349                  IF ( kcplmodel  > 1 ) THEN
350                     WRITE(cli2,'(i2.2)') jm
351                     zclname = 'model'//cli2//'_'//TRIM(zclname)
352                  ENDIF
353#if defined key_agrif
354                  IF( agrif_fixed() /= 0 ) THEN
355                     zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname)
356                  END IF
357#endif
[11101]358                  IF( ln_ctl ) THEN
359                     WRITE(numout,*) "Define", ji, jc, jm, " "//TRIM(zclname), " for ", OASIS_In
360                     IF(lflush) CALL flush(numout)
361                  ENDIF
[10159]362
[10269]363                  ! Define 0D (Greenland or Antarctic ice mass) or 1D (river outflow) coupling fields
364                  IF (srcv(ji)%dimensions <= 1) THEN
365                    var_nodims(1) = 1
366                    var_nodims(2) = 1 ! Modify this value to cater for bundled fields.
367                    IF (nproc == 0) THEN
[10159]368
[10269]369                       IF (srcv(ji)%dimensions == 0) THEN
370
371                          ! If 0D then set temporary variables to 0D components
372                          id_part_temp = id_part_0d
373                          ishape0d1d(2) = 1
374                       ELSE
375
376                          ! If 1D then set temporary variables to river outflow components
377                          id_part_temp = id_part_rnf_1d
378                          ishape0d1d(2)= nn_cpl_river
379
380                       END IF
381
382                       CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part_temp   , var_nodims,   &
383                                   OASIS_In           , ishape0d1d(1:2) , OASIS_REAL, nerror )
384                    ELSE
385                       ! Dummy call to keep OASIS3-MCT happy.
386                       CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part_0d   , var_nodims,   &
387                                   OASIS_In           , ishape0d1d(1:2) , OASIS_REAL, nerror )
388                    END IF
389                  ELSE
390                    ! It's a "normal" 2D (or pseudo 3D) coupling field.
391                    ! ... Set the field dimension and bundle count
392                    var_nodims(1) = 2
393                    var_nodims(2) = 1 ! Modify this value to cater for bundled fields.     
394
395                    CALL oasis_def_var (srcv(ji)%nid(jc,jm), zclname, id_part   , var_nodims,   &
396                                         OASIS_In           , ishape , OASIS_REAL, nerror )
397                  ENDIF
398
[4990]399                  IF ( nerror /= OASIS_Ok ) THEN
400                     WRITE(numout,*) 'Failed to define transient ', ji, jc, jm, " "//TRIM(zclname)
401                     CALL oasis_abort ( srcv(ji)%nid(jc,jm), 'cpl_define', 'Failure in oasis_def_var' )
402                  ENDIF
[11101]403                  IF(ln_ctl) THEN
404                     IF(srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple"
405                     IF(srcv(ji)%nid(jc,jm) == -1 ) WRITE(numout,*) "variable NOT defined in the namcouple"
406                     IF(lflush) CALL flush(numout)
407                  ENDIF
[4990]408               END DO
[3294]409            END DO
[1218]410         ENDIF
411      END DO
412     
[532]413      !------------------------------------------------------------------
[1218]414      ! End of definition phase
[532]415      !------------------------------------------------------------------
[1218]416     
[4990]417      CALL oasis_enddef(nerror)
418      IF( nerror /= OASIS_Ok )   CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef')
[2715]419      !
[4990]420   END SUBROUTINE cpl_define
[1218]421   
422   
[4990]423   SUBROUTINE cpl_snd( kid, kstep, pdata, kinfo )
[532]424      !!---------------------------------------------------------------------
[4990]425      !!              ***  ROUTINE cpl_snd  ***
[532]426      !!
427      !! ** Purpose : - At each coupling time-step,this routine sends fields
428      !!      like sst or ice cover to the coupler or remote application.
429      !!----------------------------------------------------------------------
[3294]430      INTEGER                   , INTENT(in   ) ::   kid       ! variable index in the array
431      INTEGER                   , INTENT(  out) ::   kinfo     ! OASIS3 info argument
432      INTEGER                   , INTENT(in   ) ::   kstep     ! ocean time-step in seconds
433      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdata
434      !!
[4990]435      INTEGER                                   ::   jc,jm     ! local loop index
[532]436      !!--------------------------------------------------------------------
437      !
[1218]438      ! snd data to OASIS3
[532]439      !
[3294]440      DO jc = 1, ssnd(kid)%nct
[4990]441         DO jm = 1, ssnd(kid)%ncplmodel
442       
443            IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN
444               CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo )
445               
446               IF ( ln_ctl ) THEN       
447                  IF ( kinfo == OASIS_Sent     .OR. kinfo == OASIS_ToRest .OR.   &
448                     & kinfo == OASIS_SentOut  .OR. kinfo == OASIS_ToRestOut ) THEN
449                     WRITE(numout,*) '****************'
450                     WRITE(numout,*) 'oasis_put: Outgoing ', ssnd(kid)%clname
451                     WRITE(numout,*) 'oasis_put: ivarid ', ssnd(kid)%nid(jc,jm)
452                     WRITE(numout,*) 'oasis_put:  kstep ', kstep
453                     WRITE(numout,*) 'oasis_put:   info ', kinfo
454                     WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata(:,:,jc))
455                     WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata(:,:,jc))
456                     WRITE(numout,*) '     -     Sum value is ', SUM(pdata(:,:,jc))
457                     WRITE(numout,*) '****************'
[11101]458                     IF(lflush) CALL flush(numout)
[4990]459                  ENDIF
460               ENDIF
461               
[3294]462            ENDIF
[4990]463           
464         ENDDO
[3294]465      ENDDO
[2715]466      !
[4990]467    END SUBROUTINE cpl_snd
[532]468
469
[4990]470   SUBROUTINE cpl_rcv( kid, kstep, pdata, pmask, kinfo )
[532]471      !!---------------------------------------------------------------------
[4990]472      !!              ***  ROUTINE cpl_rcv  ***
[532]473      !!
474      !! ** Purpose : - At each coupling time-step,this routine receives fields
475      !!      like stresses and fluxes from the coupler or remote application.
476      !!----------------------------------------------------------------------
[3294]477      INTEGER                   , INTENT(in   ) ::   kid       ! variable index in the array
478      INTEGER                   , INTENT(in   ) ::   kstep     ! ocean time-step in seconds
479      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdata     ! IN to keep the value if nothing is done
[4990]480      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pmask     ! coupling mask
[3294]481      INTEGER                   , INTENT(  out) ::   kinfo     ! OASIS3 info argument
[532]482      !!
[4990]483      INTEGER                                   ::   jc,jm     ! local loop index
484      LOGICAL                                   ::   llaction, llfisrt
[1218]485      !!--------------------------------------------------------------------
[532]486      !
[1218]487      ! receive local data from OASIS3 on every process
488      !
[4990]489      kinfo = OASIS_idle
490      !
[3294]491      DO jc = 1, srcv(kid)%nct
[4990]492         llfisrt = .TRUE.
[532]493
[4990]494         DO jm = 1, srcv(kid)%ncplmodel
495
496            IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN
497
[8280]498               CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo )   
[4990]499               
500               llaction =  kinfo == OASIS_Recvd   .OR. kinfo == OASIS_FromRest .OR.   &
[10269]501                &        kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut
[4990]502               
[11101]503               IF ( ln_ctl )   THEN
504                  WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm)
505                  IF(lflush) CALL flush(numout)
506               ENDIF
[4990]507               
508               IF ( llaction ) THEN
509                 
510                  kinfo = OASIS_Rcv
511                  IF( llfisrt ) THEN
[8280]512                     pdata(nldi:nlei,nldj:nlej,jc) =                                 exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 
[4990]513                     llfisrt = .FALSE.
514                  ELSE
515                     pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm)
516                  ENDIF
517                 
518                  IF ( ln_ctl ) THEN       
519                     WRITE(numout,*) '****************'
520                     WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname
521                     WRITE(numout,*) 'oasis_get: ivarid '  , srcv(kid)%nid(jc,jm)
522                     WRITE(numout,*) 'oasis_get:   kstep', kstep
523                     WRITE(numout,*) 'oasis_get:   info ', kinfo
524                     WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata(:,:,jc))
525                     WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata(:,:,jc))
526                     WRITE(numout,*) '     -     Sum value is ', SUM(pdata(:,:,jc))
527                     WRITE(numout,*) '****************'
[11101]528                     IF(lflush) CALL flush(numout)
[4990]529                  ENDIF
[10269]530
[4990]531               ENDIF
[10269]532
[4990]533            ENDIF
[3294]534           
[4990]535         ENDDO
[4806]536
[4990]537         !--- Fill the overlap areas and extra hallows (mpp)
538         !--- check periodicity conditions (all cases)
539         IF( .not. llfisrt )   CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn )   
540 
[3294]541      ENDDO
[2715]542      !
[4990]543   END SUBROUTINE cpl_rcv
[532]544
[10269]545   SUBROUTINE cpl_rcv_1d( kid, kstep, pdata, nitems, kinfo )
546      !!---------------------------------------------------------------------
547      !!              ***  ROUTINE cpl_rcv_1d  ***
548      !!
549      !! ** Purpose : - A special version of cpl_rcv to deal exclusively with
550      !! receipt of 0D or 1D fields.
551      !! The fields are recieved into a 1D array buffer which is simply a
552      !! dynamically sized sized array (which may be of size 1)
553      !! of 0 dimensional fields. This allows us to pass miltiple 0D
554      !! fields via a single put/get operation. 
555      !!----------------------------------------------------------------------
556      INTEGER , INTENT(in   ) ::   nitems      ! Number of 0D items to recieve
557                                               ! during this get operation. i.e.
558                                               ! The size of the 1D array in which
559                                               ! 0D items are passed.   
560      INTEGER , INTENT(in   ) ::   kid         ! ID index of the incoming
561                                               ! data. 
562      INTEGER , INTENT(in   ) ::   kstep       ! ocean time-step in seconds
563      REAL(wp), INTENT(inout) ::   pdata(1:nitems) ! The original value(s), 
564                                                   ! unchanged if nothing is
565                                                   ! received
566      INTEGER , INTENT(  out) ::   kinfo       ! OASIS3 info argument
567      !!
568      REAL(wp) ::   recvfld(1:nitems)          ! Local receive field buffer
569      INTEGER  ::   jc,jm     ! local loop index
570      INTEGER  ::   ierr
571      LOGICAL  ::   llaction
572      INTEGER  ::   MPI_WORKING_PRECISION
573      INTEGER  ::   number_to_print 
574      !!--------------------------------------------------------------------
575      !
576      ! receive local data from OASIS3 on every process
577      !
578      kinfo = OASIS_idle
579      !
580      ! 0D and 1D fields won't have categories or any other form of "pseudo level"
581      ! so we only cater for a single set of values and thus don't bother
582      ! with a loop over the jc index
583      jc = 1
[532]584
[10269]585      DO jm = 1, srcv(kid)%ncplmodel
586
587         IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN
588
589            IF ( ( srcv(kid)%dimensions <= 1) .AND. (nproc == 0) ) THEN
590               ! Since there is no concept of data decomposition for zero
591               ! dimension fields, they must only be exchanged through the master PE,
592               ! unlike "normal" 2D field cases where every PE is involved.
593
594               CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, recvfld, kinfo )   
595               
596               llaction =  kinfo == OASIS_Recvd   .OR. kinfo == OASIS_FromRest .OR.   &
597                           kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut
598               
599               IF ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , &
600                                     llaction, kinfo, kstep, srcv(kid)%nid(jc,jm)
601               
602               IF ( llaction ) THEN
603                 
604                  kinfo = OASIS_Rcv
605                  pdata(1:nitems) = recvfld(1:nitems) 
606                 
607                  IF ( ln_ctl ) THEN       
608                     number_to_print = 10
609                     IF ( nitems < number_to_print ) number_to_print = nitems
610                     WRITE(numout,*) '****************'
611                     WRITE(numout,*) 'oasis_get: Incoming ', srcv(kid)%clname
612                     WRITE(numout,*) 'oasis_get: ivarid '  , srcv(kid)%nid(jc,jm)
613                     WRITE(numout,*) 'oasis_get:   kstep', kstep
614                     WRITE(numout,*) 'oasis_get:   info ', kinfo
615                     WRITE(numout,*) '     - Minimum Value is ', MINVAL(pdata(:))
616                     WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata(:))
617                     WRITE(numout,*) '     - Start of data is ', pdata(1:number_to_print)
618                     WRITE(numout,*) '****************'
[11101]619                     IF(lflush) CALL flush(numout)
[10269]620                  ENDIF
621                 
622               ENDIF
623            ENDIF   
624          ENDIF
625           
626       ENDDO
627       
628       ! Set the precision that we want to broadcast using MPI_BCAST
629       SELECT CASE( wp )
630       CASE( sp ) 
631         MPI_WORKING_PRECISION = MPI_REAL                ! Single precision
632       CASE( dp )
633         MPI_WORKING_PRECISION = MPI_DOUBLE_PRECISION    ! Double precision
634       CASE default
635         CALL oasis_abort( ncomp_id, "cpl_rcv_1d", "Could not find precision for coupling 0d or 1d field" )
636       END SELECT
637
638       ! We have to broadcast (potentially) received values from PE 0 to all
639       ! the others. If no new data has been received we're just
640       ! broadcasting the existing values but there's no more efficient way
641       ! to deal with that w/o NEMO adopting a UM-style test mechanism
642       ! to determine active put/get timesteps.
643       CALL mpi_bcast( pdata, nitems, MPI_WORKING_PRECISION, localRoot, mpi_comm_opa, ierr )
644
645      !
646   END SUBROUTINE cpl_rcv_1d
647
648
[5407]649   INTEGER FUNCTION cpl_freq( cdfieldname ) 
[2528]650      !!---------------------------------------------------------------------
[4990]651      !!              ***  ROUTINE cpl_freq  ***
[2528]652      !!
653      !! ** Purpose : - send back the coupling frequency for a particular field
654      !!----------------------------------------------------------------------
[5407]655      CHARACTER(len = *), INTENT(in) ::   cdfieldname    ! field name as set in namcouple file
[4990]656      !!
[5407]657      INTEGER               :: id
[4990]658      INTEGER               :: info
659      INTEGER, DIMENSION(1) :: itmp
[5407]660      INTEGER               :: ji,jm     ! local loop index
661      INTEGER               :: mop
[2715]662      !!----------------------------------------------------------------------
[5407]663      cpl_freq = 0   ! defaut definition
664      id = -1        ! defaut definition
[2715]665      !
[5407]666      DO ji = 1, nsnd
667         IF (ssnd(ji)%laction ) THEN
668            DO jm = 1, ncplmodel
669               IF( ssnd(ji)%nid(1,jm) /= -1 ) THEN
670                  IF( TRIM(cdfieldname) == TRIM(ssnd(ji)%clname) ) THEN
671                     id = ssnd(ji)%nid(1,jm)
672                     mop = OASIS_Out
673                  ENDIF
674               ENDIF
675            ENDDO
676         ENDIF
677      ENDDO
678      DO ji = 1, nrcv
679         IF (srcv(ji)%laction ) THEN
680            DO jm = 1, ncplmodel
681               IF( srcv(ji)%nid(1,jm) /= -1 ) THEN
682                  IF( TRIM(cdfieldname) == TRIM(srcv(ji)%clname) ) THEN
683                     id = srcv(ji)%nid(1,jm)
684                     mop = OASIS_In
685                  ENDIF
686               ENDIF
687            ENDDO
688         ENDIF
689      ENDDO
690      !
691      IF( id /= -1 ) THEN
692#if defined key_oa3mct_v3
693         CALL oasis_get_freqs(id, mop, 1, itmp, info)
694#else
[8280]695#if defined key_oasis3 
696         itmp(1) = namflddti( id )
697#else
[5407]698         CALL oasis_get_freqs(id,      1, itmp, info)
699#endif
[8280]700#endif
[5407]701         cpl_freq = itmp(1)
702      ENDIF
703      !
[4990]704   END FUNCTION cpl_freq
[2528]705
706
[4990]707   SUBROUTINE cpl_finalize
[532]708      !!---------------------------------------------------------------------
[4990]709      !!              ***  ROUTINE cpl_finalize  ***
[532]710      !!
711      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
[4990]712      !!      called explicitly before cpl_init it will also close
[532]713      !!      MPI communication.
714      !!----------------------------------------------------------------------
[2715]715      !
716      DEALLOCATE( exfld )
[4990]717      IF (nstop == 0) THEN
718         CALL oasis_terminate( nerror )         
719      ELSE
720         CALL oasis_abort( ncomp_id, "cpl_finalize", "NEMO ABORT STOP" )
721      ENDIF       
[2715]722      !
[4990]723   END SUBROUTINE cpl_finalize
[532]724
[4990]725#if ! defined key_oasis3
726
[1218]727   !!----------------------------------------------------------------------
[4990]728   !!   No OASIS Library          OASIS3 Dummy module...
[1218]729   !!----------------------------------------------------------------------
[4990]730
731   SUBROUTINE oasis_init_comp(k1,cd1,k2)
732      CHARACTER(*), INTENT(in   ) ::  cd1
733      INTEGER     , INTENT(  out) ::  k1,k2
734      k1 = -1 ; k2 = -1
735      WRITE(numout,*) 'oasis_init_comp: Error you sould not be there...', cd1
736   END SUBROUTINE oasis_init_comp
737
738   SUBROUTINE oasis_abort(k1,cd1,cd2)
739      INTEGER     , INTENT(in   ) ::  k1
740      CHARACTER(*), INTENT(in   ) ::  cd1,cd2
741      WRITE(numout,*) 'oasis_abort: Error you sould not be there...', cd1, cd2
742   END SUBROUTINE oasis_abort
743
744   SUBROUTINE oasis_get_localcomm(k1,k2)
745      INTEGER     , INTENT(  out) ::  k1,k2
746      k1 = -1 ; k2 = -1
747      WRITE(numout,*) 'oasis_get_localcomm: Error you sould not be there...'
748   END SUBROUTINE oasis_get_localcomm
749
[8280]750   SUBROUTINE oasis_def_partition(k1,k2,k3,K4)
[4990]751      INTEGER     , INTENT(  out) ::  k1,k3
752      INTEGER     , INTENT(in   ) ::  k2(5)
[8280]753      INTEGER     , OPTIONAL, INTENT(in   ) ::  k4
[4990]754      k1 = k2(1) ; k3 = k2(5)
755      WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...'
756   END SUBROUTINE oasis_def_partition
757
758   SUBROUTINE oasis_def_var(k1,cd1,k2,k3,k4,k5,k6,k7)
759      CHARACTER(*), INTENT(in   ) ::  cd1
[10269]760      INTEGER     , INTENT(in   ) ::  k2,k3(2),k4,k5(*),k6
[4990]761      INTEGER     , INTENT(  out) ::  k1,k7
762      k1 = -1 ; k7 = -1
763      WRITE(numout,*) 'oasis_def_var: Error you sould not be there...', cd1
764   END SUBROUTINE oasis_def_var
765
766   SUBROUTINE oasis_enddef(k1)
767      INTEGER     , INTENT(  out) ::  k1
768      k1 = -1
769      WRITE(numout,*) 'oasis_enddef: Error you sould not be there...'
770   END SUBROUTINE oasis_enddef
771 
772   SUBROUTINE oasis_put(k1,k2,p1,k3)
773      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::  p1
774      INTEGER                 , INTENT(in   ) ::  k1,k2
775      INTEGER                 , INTENT(  out) ::  k3
776      k3 = -1
777      WRITE(numout,*) 'oasis_put: Error you sould not be there...'
778   END SUBROUTINE oasis_put
779
[10269]780   SUBROUTINE oasis_get_1d(k1,k2,p1,k3)
781      REAL(wp), DIMENSION(:)  , INTENT(  out) ::  p1
782      INTEGER                 , INTENT(in   ) ::  k1,k2
783      INTEGER                 , INTENT(  out) ::  k3
784      p1(1) = -1. ; k3 = -1
785      WRITE(numout,*) 'oasis_get_1d: Error you sould not be there...'
786   END SUBROUTINE oasis_get_1d
787
788   SUBROUTINE oasis_get_2d(k1,k2,p1,k3)
[4990]789      REAL(wp), DIMENSION(:,:), INTENT(  out) ::  p1
790      INTEGER                 , INTENT(in   ) ::  k1,k2
791      INTEGER                 , INTENT(  out) ::  k3
792      p1(1,1) = -1. ; k3 = -1
[10269]793      WRITE(numout,*) 'oasis_get_2d: Error you sould not be there...'
794   END SUBROUTINE oasis_get_2d
[4990]795
796   SUBROUTINE oasis_get_freqs(k1,k2,k3,k4)
797      INTEGER              , INTENT(in   ) ::  k1,k2
798      INTEGER, DIMENSION(1), INTENT(  out) ::  k3
799      INTEGER              , INTENT(  out) ::  k4
800      k3(1) = k1 ; k4 = k2
801      WRITE(numout,*) 'oasis_get_freqs: Error you sould not be there...'
802   END SUBROUTINE oasis_get_freqs
803
804   SUBROUTINE oasis_terminate(k1)
805      INTEGER     , INTENT(  out) ::  k1
806      k1 = -1
807      WRITE(numout,*) 'oasis_terminate: Error you sould not be there...'
808   END SUBROUTINE oasis_terminate
809   
[532]810#endif
811
[2715]812   !!=====================================================================
[532]813END MODULE cpl_oasis3
Note: See TracBrowser for help on using the repository browser.