Changeset 4827 for branches/UKMO/dev_3841_sbc/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

Timestamp:

2014-10-31T12:45:41+01:00 (9 years ago)

Author:

charris

Message:

Some demonstration code changes.

File:

• branches/UKMO/dev_3841_sbc/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90 (modified) (11 diffs)

branches/UKMO/dev_3841_sbc/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

@@ -34 +34 @@
    USE in_out_manager               ! I/O manager
    USE lbclnk                       ! ocean lateral boundary conditions (or mpp link)
+   USE fld_def
 
    IMPLICIT NONE
@@ -46 +47 @@
 
    LOGICAL, PUBLIC, PARAMETER ::   lk_cpl = .TRUE.   !: coupled flag
-   INTEGER, PUBLIC            ::   OASIS_Rcv  = 1    !: return code if received field
-   INTEGER, PUBLIC            ::   OASIS_idle = 0    !: return code if nothing done by oasis
    INTEGER                    ::   ncomp_id          ! id returned by prism_init_comp
    INTEGER                    ::   nerror            ! return error code
@@ -62 +61 @@
    END TYPE FLD_CPL
 
-   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC ::   srcv, ssnd   !: Coupling fields
+   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC ::   ssnd   !: Coupling fields
 
    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   exfld   ! Temporary buffer for receiving
+   INTEGER, PUBLIC :: localComm
 
    !!----------------------------------------------------------------------
@@ -106 +106 @@
 
 
-   SUBROUTINE cpl_prism_define( krcv, ksnd )
+   SUBROUTINE cpl_prism_define( krcv, ksnd, sd )
       !!-------------------------------------------------------------------
       !!             ***  ROUTINE cpl_prism_define  ***
@@ -115 +115 @@
       !! ** Method  :   OASIS3 MPI communication 
       !!--------------------------------------------------------------------
-      INTEGER, INTENT(in) ::   krcv, ksnd     ! Number of received and sent coupling fields
+      INTEGER, INTENT(in)                  ::   krcv, ksnd  ! Number of received and sent coupling fields
+      TYPE(FLD), INTENT(in), DIMENSION(:)  ::   sd          ! input field related variables
       !
       INTEGER :: id_part
@@ -187 +188 @@
       !
       DO ji = 1, krcv
-         IF ( srcv(ji)%laction ) THEN 
-            DO jc = 1, srcv(ji)%nct
-               IF ( srcv(ji)%nct .gt. 1 ) THEN
-                  WRITE(zclname,'( a7, i1)') srcv(ji)%clname,jc
+         IF ( sd(ji)%loasis ) THEN 
+            DO jc = 1, sd(ji)%nct
+               IF ( sd(ji)%nct .gt. 1 ) THEN
+                  WRITE(zclname,'( a7, i1)') sd(ji)%clvar,jc
                ELSE
-                  zclname=srcv(ji)%clname
+                  zclname=sd(ji)%clvar
                ENDIF
                WRITE(numout,*) "Define",ji,jc,zclname," for",PRISM_In
-               CALL prism_def_var_proto ( srcv(ji)%nid(jc), zclname, id_part, (/ 2, 0/),   &
+               CALL prism_def_var_proto ( sd(ji)%nid(jc), zclname, id_part, (/ 2, 0/),   &
                     &                      PRISM_In    , ishape   , PRISM_REAL, nerror)
                IF ( nerror /= PRISM_Ok ) THEN
                   WRITE(numout,*) 'Failed to define transient ', ji, TRIM(zclname)
-                  CALL prism_abort_proto ( srcv(ji)%nid(jc), 'cpl_prism_define', 'Failure in prism_def_var')
+                  CALL prism_abort_proto ( sd(ji)%nid(jc), 'cpl_prism_define', 'Failure in prism_def_var')
                ENDIF
             END DO
@@ -256 +257 @@
 
 
-   SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo )
+   SUBROUTINE cpl_prism_rcv( kstep, sd )
       !!---------------------------------------------------------------------
       !!              ***  ROUTINE cpl_prism_rcv  ***
@@ -263 +264 @@
       !!      like stresses and fluxes from the coupler or remote application.
       !!----------------------------------------------------------------------
-      INTEGER                   , INTENT(in   ) ::   kid       ! variable index in the array
       INTEGER                   , INTENT(in   ) ::   kstep     ! ocean time-step in seconds
-      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdata     ! IN to keep the value if nothing is done
-      INTEGER                   , INTENT(  out) ::   kinfo     ! OASIS3 info argument
+      TYPE(FLD), INTENT(inout)                  ::   sd        ! input field related variables
       !!
       INTEGER                                   ::   jc        ! local loop index
@@ -274 +273 @@
       ! receive local data from OASIS3 on every process
       !
-      DO jc = 1, srcv(kid)%nct
-
-         CALL prism_get_proto ( srcv(kid)%nid(jc), kstep, exfld, kinfo )         
+      DO jc = 1, sd%nct
+
+         CALL prism_get_proto ( sd%nid(jc), kstep, exfld, sd%ninfo )         
          
          llaction = .false.
-         IF( kinfo == PRISM_Recvd   .OR. kinfo == PRISM_FromRest .OR.   &
-              kinfo == PRISM_RecvOut .OR. kinfo == PRISM_FromRestOut )   llaction = .TRUE.
-         
-         IF ( ln_ctl )   WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc)
+         IF( sd%ninfo == PRISM_Recvd   .OR. sd%ninfo == PRISM_FromRest .OR.   &
+              sd%ninfo == PRISM_RecvOut .OR. sd%ninfo == PRISM_FromRestOut )   llaction = .TRUE.
+         
+         IF ( ln_ctl )   WRITE(numout,*) "llaction, info, kstep, ivarid: " , llaction, sd%ninfo, kstep, sd%nid(jc)
          
          IF ( llaction ) THEN
             
-            kinfo = OASIS_Rcv
-            pdata(nldi:nlei, nldj:nlej,jc) = exfld(:,:)
+            sd%ninfo = OASIS_Rcv
+            sd%fnow(nldi:nlei, nldj:nlej,jc) = exfld(:,:)
             
             !--- Fill the overlap areas and extra hallows (mpp)
             !--- check periodicity conditions (all cases)
-            CALL lbc_lnk( pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn )   
+            CALL lbc_lnk( sd%fnow(:,:,jc), sd%clvgrd, sd%nsgn )   
             
             IF ( ln_ctl ) THEN        
                WRITE(numout,*) '****************'
-               WRITE(numout,*) 'prism_get_proto: Incoming ', srcv(kid)%clname
-               WRITE(numout,*) 'prism_get_proto: ivarid '  , srcv(kid)%nid(jc)
+               WRITE(numout,*) 'prism_get_proto: Incoming ', sd%clvar
+               WRITE(numout,*) 'prism_get_proto: ivarid '  , sd%nid(jc)
                WRITE(numout,*) 'prism_get_proto:   kstep', kstep
-               WRITE(numout,*) 'prism_get_proto:   info ', kinfo
-               WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata(:,:,jc))
-               WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata(:,:,jc))
-               WRITE(numout,*) '     -     Sum value is ', SUM(pdata(:,:,jc))
+               WRITE(numout,*) 'prism_get_proto:   info ', sd%ninfo
+               WRITE(numout,*) '     - Minimum value is ', MINVAL(sd%fnow(:,:,jc))
+               WRITE(numout,*) '     - Maximum value is ', MAXVAL(sd%fnow(:,:,jc))
+               WRITE(numout,*) '     -     Sum value is ', SUM(sd%fnow(:,:,jc))
                WRITE(numout,*) '****************'
             ENDIF
             
          ELSE
-            kinfo = OASIS_idle     
+            sd%ninfo = OASIS_idle     
          ENDIF
          
@@ -346 +345 @@
    !!----------------------------------------------------------------------
    USE in_out_manager               ! I/O manager
+   USE fld_def
    LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .FALSE.   !: coupled flag
    PUBLIC cpl_prism_init
+   PUBLIC cpl_prism_rcv
    PUBLIC cpl_prism_finalize
 CONTAINS
@@ -355 +356 @@
       WRITE(numout,*) 'cpl_prism_init: Error you sould not be there...'
    END SUBROUTINE cpl_prism_init
+   SUBROUTINE cpl_prism_rcv ( kstep, sd )
+      INTEGER, INTENT(in   )   ::   kstep     ! ocean time-step in seconds
+      TYPE(FLD), INTENT(inout) ::   sd        ! input field related variables
+      WRITE(numout,*) 'cpl_prism_rcv: Error you sould not be there...'
+   END SUBROUTINE cpl_prism_rcv
    SUBROUTINE cpl_prism_finalize
       WRITE(numout,*) 'cpl_prism_finalize: Error you sould not be there...'