Changeset 15225 for NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_prep.F90

Timestamp:

2021-09-02T17:52:53+02:00 (3 years ago)

Author:

dford

Message:

Improve handling of velocities, including adding surface currents.

File:

• NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_prep.F90 (modified) (10 diffs)

NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_prep.F90

@@ -22 +22 @@
    USE obs_inter_sup      ! Interpolation support
    USE obs_oper           ! Observation operators
+   USE obs_field, ONLY : &  ! Velocity variable names
+      & cobsname_uvel, &
+      & cobsname_vvel
    USE lib_mpp, ONLY :   ctl_warn, ctl_stop
    USE bdy_oce, ONLY : &        ! Boundary information
@@ -150 +153 @@
       ! -----------------------------------------------------------------------
 
-      CALL obs_coo_grd( surfdata%nsurf,   surfdata%mi, surfdata%mj, &
-         &              surfdata%nqc,     igrdobs                         )
+      DO jvar = 1, surfdata%nvar
+         CALL obs_coo_grd( surfdata%nsurf,      surfdata%mi(:,jvar),         &
+            &              surfdata%mj(:,jvar), surfdata%nqc,        igrdobs )
+      END DO
 
       CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp )
@@ -160 +165 @@
 
       DO jvar = 1, surfdata%nvar
-         CALL obs_coo_spc_2d( surfdata%nsurf,                   &
-            &                 jpi,             jpj,             &
-            &                 surfdata%mi,     surfdata%mj,     & 
-            &                 surfdata%rlam,   surfdata%rphi,   &
-            &                 pglam(:,:,jvar), pgphi(:,:,jvar), &
-            &                 zmask(:,:,jvar), surfdata%nqc,    &
-            &                 iosdsobs(jvar),  ilansobs(jvar),  &
-            &                 inlasobs(jvar),  ld_nea,          &
-            &                 ibdysobs(jvar),  ld_bound_reject, &
+         CALL obs_coo_spc_2d( surfdata%nsurf,                           &
+            &                 jpi,                 jpj,                 &
+            &                 surfdata%mi(:,jvar), surfdata%mj(:,jvar), & 
+            &                 surfdata%rlam,       surfdata%rphi,       &
+            &                 pglam(:,:,jvar),     pgphi(:,:,jvar),     &
+            &                 zmask(:,:,jvar),     surfdata%nqc,        &
+            &                 iosdsobs(jvar),      ilansobs(jvar),      &
+            &                 inlasobs(jvar),      ld_nea,              &
+            &                 ibdysobs(jvar),      ld_bound_reject,     &
             &                 iqc_cutoff                     )
          CALL obs_mpp_sum_integer( iosdsobs(jvar), iosdsobsmpp(jvar) )
@@ -333 +338 @@
       INTEGER :: iuvchkumpp                            !  - reject UVEL if VVEL rejected
       INTEGER :: iuvchkvmpp                            !  - reject VVEL if UVEL rejected
+      INTEGER :: iuvar                                 !  - UVEL index
+      INTEGER :: ivvar                                 !  - VVEL index
       TYPE(obs_prof_valid) ::  llvalid      ! Profile selection 
       TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: &
@@ -443 +450 @@
       ! -----------------------------------------------------------------------
 
-      IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN
-         CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff )
+      iuvar = 0
+      ivvar = 0
+      DO jvar = 1,profdata%nvar
+         IF ( TRIM(profdata%cvars(jvar)) == cobsname_uvel ) THEN
+            iuvar = jvar
+         ELSEIF ( TRIM(profdata%cvars(jvar)) == cobsname_vvel ) THEN
+            ivvar = jvar
+         ENDIF
+      END DO
+      IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN
+         CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff, iuvar, ivvar )
          CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp )
          CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp )
@@ -504 +520 @@
                   &            inlavobsmpp(jvar)
             ENDIF
-            IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN
-               WRITE(numout,*) ' U observation rejected since V rejected     = ', &
-                  &            iuvchku
-            ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN
-               WRITE(numout,*) ' V observation rejected since U rejected     = ', &
-                  &            iuvchkv
+            IF ( (iuvar > 0) .AND. (ivvar > 0) ) THEN
+               IF ( TRIM(profdata%cvars(jvar)) == cobsname_uvel ) THEN
+                  WRITE(numout,*) ' U observation rejected since V rejected     = ', &
+                     &            iuvchku
+               ELSE IF ( TRIM(profdata%cvars(jvar)) == cobsname_vvel ) THEN
+                  WRITE(numout,*) ' V observation rejected since U rejected     = ', &
+                     &            iuvchkv
+               ENDIF
             ENDIF
             WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',&
@@ -1374 +1392 @@
 
 
-   SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff )
+   SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff, kuvar, kvvar )
       !!----------------------------------------------------------------------
       !!                    ***  ROUTINE obs_uv_rej ***
@@ -1391 +1409 @@
       INTEGER, INTENT(INOUT) :: knumu             ! Number of u rejected
       INTEGER, INTENT(INOUT) :: knumv             ! Number of v rejected
-      INTEGER, INTENT(IN) :: kqc_cutoff           ! QC cutoff value
+      INTEGER, INTENT(IN)    :: kqc_cutoff        ! QC cutoff value
+      INTEGER, INTENT(IN)    :: kuvar             ! Index of u
+      INTEGER, INTENT(IN)    :: kvvar             ! Index of v
       !
       INTEGER :: jprof
@@ -1400 +1420 @@
       DO jprof = 1, profdata%nprof      !==  Loop over profiles  ==!
          !
-         IF ( ( profdata%npvsta(jprof,1) /= profdata%npvsta(jprof,2) ) .OR. &
-            & ( profdata%npvend(jprof,1) /= profdata%npvend(jprof,2) ) ) THEN
+         IF ( ( profdata%npvsta(jprof,kuvar) /= profdata%npvsta(jprof,kvvar) ) .OR. &
+            & ( profdata%npvend(jprof,kuvar) /= profdata%npvend(jprof,kvvar) ) ) THEN
             !
             CALL ctl_stop('U,V profiles inconsistent in obs_uv_rej')
@@ -1408 +1428 @@
          ENDIF
          !
-         DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1)
+         DO jobs = profdata%npvsta(jprof,kuvar), profdata%npvend(jprof,kuvar)
             !  
-            IF ( ( profdata%var(1)%nvqc(jobs) >  kqc_cutoff ) .AND. &
-               & ( profdata%var(2)%nvqc(jobs) <=  kqc_cutoff) ) THEN
-               profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15)
+            IF ( ( profdata%var(kuvar)%nvqc(jobs) >  kqc_cutoff ) .AND. &
+               & ( profdata%var(kvvar)%nvqc(jobs) <=  kqc_cutoff) ) THEN
+               profdata%var(kvvar)%nvqc(jobs) = IBSET(profdata%var(kuvar)%nvqc(jobs),15)
                knumv = knumv + 1
             ENDIF
-            IF ( ( profdata%var(2)%nvqc(jobs) >  kqc_cutoff ) .AND. &
-               & ( profdata%var(1)%nvqc(jobs) <=  kqc_cutoff) ) THEN
-               profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15)
+            IF ( ( profdata%var(kvvar)%nvqc(jobs) >  kqc_cutoff ) .AND. &
+               & ( profdata%var(kuvar)%nvqc(jobs) <=  kqc_cutoff) ) THEN
+               profdata%var(kuvar)%nvqc(jobs) = IBSET(profdata%var(kuvar)%nvqc(jobs),15)
                knumu = knumu + 1
             ENDIF