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.
Changeset 9306 for branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90 – NEMO

Ignore:
Timestamp:
2018-02-05T16:07:40+01:00 (6 years ago)
Author:
dford
Message:

Add extra biogeochemical variables to OBS code, and make profile obs operator code more generic. See internal Met Office NEMO ticket 733.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90

    r8222 r9306  
    255255 
    256256 
    257    SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, & 
     257   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 
    258258      &                     kpi, kpj, kpk, & 
    259       &                     zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2,  & 
     259      &                     zmask, pglam, pgphi,  & 
    260260      &                     ld_nea, ld_bound_reject, kdailyavtypes,  kqc_cutoff ) 
    261261 
    … …  
    284284      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    285285      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening 
    286       LOGICAL, INTENT(IN) :: ld_var1              ! Observed variables switches 
    287       LOGICAL, INTENT(IN) :: ld_var2 
     286      LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 
     287         & ld_var                                 ! Observed variables switches 
    288288      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land 
    289289      LOGICAL, INTENT(IN) :: ld_bound_reject      ! Switch for rejecting observations near the boundary 
    … …  
    291291      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    292292         & kdailyavtypes                          ! Types for daily averages 
    293       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    294          & zmask1, & 
    295          & zmask2 
    296       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    297          & pglam1, & 
    298          & pglam2, & 
    299          & pgphi1, & 
    300          & pgphi2 
     293      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 
     294         & zmask 
     295      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 
     296         & pglam, & 
     297         & pgphi 
    301298      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value 
    302299 
    … …  
    309306      INTEGER :: imin0 
    310307      INTEGER :: icycle       ! Current assimilation cycle 
    311                               ! Counters for observations that are 
    312       INTEGER :: iotdobs      !  - outside time domain 
    313       INTEGER :: iosdv1obs    !  - outside space domain (variable 1) 
    314       INTEGER :: iosdv2obs    !  - outside space domain (variable 2) 
    315       INTEGER :: ilanv1obs    !  - within a model land cell (variable 1) 
    316       INTEGER :: ilanv2obs    !  - within a model land cell (variable 2) 
    317       INTEGER :: inlav1obs    !  - close to land (variable 1) 
    318       INTEGER :: inlav2obs    !  - close to land (variable 2) 
    319       INTEGER :: ibdyv1obs    !  - boundary (variable 1)  
    320       INTEGER :: ibdyv2obs    !  - boundary (variable 2)       
    321       INTEGER :: igrdobs      !  - fail the grid search 
    322       INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    323       INTEGER :: iuvchkv      ! 
    324                               ! Global counters for observations that are 
    325       INTEGER :: iotdobsmpp   !  - outside time domain 
    326       INTEGER :: iosdv1obsmpp !  - outside space domain (variable 1) 
    327       INTEGER :: iosdv2obsmpp !  - outside space domain (variable 2) 
    328       INTEGER :: ilanv1obsmpp !  - within a model land cell (variable 1) 
    329       INTEGER :: ilanv2obsmpp !  - within a model land cell (variable 2) 
    330       INTEGER :: inlav1obsmpp !  - close to land (variable 1) 
    331       INTEGER :: inlav2obsmpp !  - close to land (variable 2) 
    332       INTEGER :: ibdyv1obsmpp !  - boundary (variable 1)  
    333       INTEGER :: ibdyv2obsmpp !  - boundary (variable 2)       
    334       INTEGER :: igrdobsmpp   !  - fail the grid search 
    335       INTEGER :: iuvchkumpp   !  - reject var1 if var2 rejected and vice versa 
    336       INTEGER :: iuvchkvmpp   ! 
     308                                                       ! Counters for observations that are 
     309      INTEGER                           :: iotdobs     !  - outside time domain 
     310      INTEGER, DIMENSION(profdata%nvar) :: iosdvobs    !  - outside space domain 
     311      INTEGER, DIMENSION(profdata%nvar) :: ilanvobs    !  - within a model land cell 
     312      INTEGER, DIMENSION(profdata%nvar) :: inlavobs    !  - close to land 
     313      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs    !  - boundary    
     314      INTEGER                           :: igrdobs     !  - fail the grid search 
     315      INTEGER                           :: iuvchku     !  - reject UVEL if VVEL rejected 
     316      INTEGER                           :: iuvchkv     !  - reject VVEL if UVEL rejected 
     317                                                       ! Global counters for observations that are 
     318      INTEGER                           :: iotdobsmpp  !  - outside time domain 
     319      INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp !  - outside space domain 
     320      INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp !  - within a model land cell 
     321      INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp !  - close to land 
     322      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp !  - boundary 
     323      INTEGER :: igrdobsmpp                            !  - fail the grid search 
     324      INTEGER :: iuvchkumpp                            !  - reject UVEL if VVEL rejected 
     325      INTEGER :: iuvchkvmpp                            !  - reject VVEL if UVEL rejected 
    337326      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
    338327      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    339          & llvvalid           ! var1,var2 selection  
     328         & llvvalid           ! vars selection  
    340329      INTEGER :: jvar         ! Variable loop variable 
    341330      INTEGER :: jobs         ! Obs. loop variable 
    342331      INTEGER :: jstp         ! Time loop variable 
    343332      INTEGER :: inrc         ! Time index variable 
     333      CHARACTER(LEN=256) :: cout1  ! Diagnostic output line 
     334      CHARACTER(LEN=256) :: cout2  ! Diagnostic output line 
    344335 
    345336      IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' 
    … …  
    355346      icycle = no     ! Assimilation cycle 
    356347 
    357       ! Diagnotics counters for various failures. 
    358  
    359       iotdobs   = 0 
    360       igrdobs   = 0 
    361       iosdv1obs = 0 
    362       iosdv2obs = 0 
    363       ilanv1obs = 0 
    364       ilanv2obs = 0 
    365       inlav1obs = 0 
    366       inlav2obs = 0 
    367       ibdyv1obs = 0 
    368       ibdyv2obs = 0 
    369       iuvchku   = 0 
    370       iuvchkv   = 0 
     348      ! Diagnostics counters for various failures. 
     349 
     350      iotdobs     = 0 
     351      igrdobs     = 0 
     352      iosdvobs(:) = 0 
     353      ilanvobs(:) = 0 
     354      inlavobs(:) = 0 
     355      ibdyvobs(:) = 0 
     356      iuvchku     = 0 
     357      iuvchkv     = 0 
    371358 
    372359 
    … …  
    401388      ! ----------------------------------------------------------------------- 
    402389 
    403       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,1), profdata%mj(:,1), & 
    404          &              profdata%nqc,     igrdobs                         ) 
    405       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,2), profdata%mj(:,2), & 
    406          &              profdata%nqc,     igrdobs                         ) 
     390      DO jvar = 1, profdata%nvar 
     391         CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,jvar), profdata%mj(:,jvar), & 
     392            &              profdata%nqc,     igrdobs ) 
     393      END DO 
    407394 
    408395      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    … …  
    419406      ! ----------------------------------------------------------------------- 
    420407 
    421       ! Variable 1 
    422       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    423          &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    424          &                 jpi,                   jpj,                  & 
    425          &                 jpk,                                         & 
    426          &                 profdata%mi,           profdata%mj,          & 
    427          &                 profdata%var(1)%mvk,                         & 
    428          &                 profdata%rlam,         profdata%rphi,        & 
    429          &                 profdata%var(1)%vdep,                        & 
    430          &                 pglam1,                pgphi1,               & 
    431          &                 gdept_1d,              zmask1,               & 
    432          &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    433          &                 iosdv1obs,             ilanv1obs,            & 
    434          &                 inlav1obs,             ld_nea,               & 
    435          &                 ibdyv1obs,             ld_bound_reject,      & 
    436          &                 iqc_cutoff       ) 
    437  
    438       CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 
    439       CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 
    440       CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 
    441       CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 
    442  
    443       ! Variable 2 
    444       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    445          &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    446          &                 jpi,                   jpj,                  & 
    447          &                 jpk,                                         & 
    448          &                 profdata%mi,           profdata%mj,          &  
    449          &                 profdata%var(2)%mvk,                         & 
    450          &                 profdata%rlam,         profdata%rphi,        & 
    451          &                 profdata%var(2)%vdep,                        & 
    452          &                 pglam2,                pgphi2,               & 
    453          &                 gdept_1d,              zmask2,               & 
    454          &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    455          &                 iosdv2obs,             ilanv2obs,            & 
    456          &                 inlav2obs,             ld_nea,               & 
    457          &                 ibdyv2obs,             ld_bound_reject,      & 
    458          &                 iqc_cutoff       ) 
    459  
    460       CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 
    461       CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 
    462       CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 
    463       CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 
     408      DO jvar = 1, profdata%nvar 
     409         CALL obs_coo_spc_3d( profdata%nprof,          profdata%nvprot(jvar),   & 
     410            &                 profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 
     411            &                 jpi,                     jpj,                     & 
     412            &                 jpk,                                              & 
     413            &                 profdata%mi,             profdata%mj,             & 
     414            &                 profdata%var(jvar)%mvk,                           & 
     415            &                 profdata%rlam,           profdata%rphi,           & 
     416            &                 profdata%var(jvar)%vdep,                          & 
     417            &                 pglam(:,:,jvar),         pgphi(:,:,jvar),         & 
     418            &                 gdept_1d,                zmask(:,:,:,jvar),       & 
     419            &                 profdata%nqc,            profdata%var(jvar)%nvqc, & 
     420            &                 iosdvobs(jvar),          ilanvobs(jvar),          & 
     421            &                 inlavobs(jvar),          ld_nea,                  & 
     422            &                 ibdyvobs(jvar),          ld_bound_reject,         & 
     423            &                 iqc_cutoff       ) 
     424 
     425         CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 
     426         CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 
     427         CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 
     428         CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 
     429      END DO 
    464430 
    465431      ! ----------------------------------------------------------------------- 
    … …  
    512478       
    513479         WRITE(numout,*) 
    514          WRITE(numout,*) ' Profiles outside time domain                     = ', & 
     480         WRITE(numout,*) ' Profiles outside time domain                       = ', & 
    515481            &            iotdobsmpp 
    516          WRITE(numout,*) ' Remaining profiles that failed grid search       = ', & 
     482         WRITE(numout,*) ' Remaining profiles that failed grid search         = ', & 
    517483            &            igrdobsmpp 
    518          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain       = ', & 
    519             &            iosdv1obsmpp 
    520          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points             = ', & 
    521             &            ilanv1obsmpp 
    522          IF (ld_nea) THEN 
    523             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 
    524                &            inlav1obsmpp 
    525          ELSE 
    526             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept)    = ',& 
    527                &            inlav1obsmpp 
    528          ENDIF 
    529          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    530             WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
    531                &            iuvchku 
    532          ENDIF 
    533          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 
    534                &            ibdyv1obsmpp 
    535          WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted                             = ', & 
    536             &            prodatqc%nvprotmpp(1) 
    537          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain       = ', & 
    538             &            iosdv2obsmpp 
    539          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points             = ', & 
    540             &            ilanv2obsmpp 
    541          IF (ld_nea) THEN 
    542             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 
    543                &            inlav2obsmpp 
    544          ELSE 
    545             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept)    = ',& 
    546                &            inlav2obsmpp 
    547          ENDIF 
    548          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    549             WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
    550                &            iuvchkv 
    551          ENDIF 
    552          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 
    553                &            ibdyv2obsmpp 
    554          WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted                             = ', & 
    555             &            prodatqc%nvprotmpp(2) 
     484         DO jvar = 1, profdata%nvar 
     485            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain       = ', & 
     486               &            iosdvobsmpp(jvar) 
     487            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points             = ', & 
     488               &            ilanvobsmpp(jvar) 
     489            IF (ld_nea) THEN 
     490               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 
     491                  &            inlavobsmpp(jvar) 
     492            ELSE 
     493               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept)    = ',& 
     494                  &            inlavobsmpp(jvar) 
     495            ENDIF 
     496            IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 
     497               WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
     498                  &            iuvchku 
     499            ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 
     500               WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
     501                  &            iuvchkv 
     502            ENDIF 
     503            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 
     504                  &            ibdyvobsmpp(jvar) 
     505            WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted                             = ', & 
     506               &            prodatqc%nvprotmpp(jvar) 
     507         END DO 
    556508 
    557509         WRITE(numout,*) 
    558510         WRITE(numout,*) ' Number of observations per time step :' 
    559511         WRITE(numout,*) 
    560          WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 
    561             &                               '     '//prodatqc%cvars(1)//'     ', & 
    562             &                               '     '//prodatqc%cvars(2)//'     ' 
    563          WRITE(numout,998) 
     512         WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 
     513         WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 
     514         DO jvar = 1, prodatqc%nvar 
     515            WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 
     516            WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 
     517         END DO 
     518         WRITE(numout,*) cout1 
     519         WRITE(numout,*) cout2 
    564520      ENDIF 
    565521       
    … …  
    588544         DO jstp = nit000 - 1, nitend 
    589545            inrc = jstp - nit000 + 2 
    590             WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    591                &                    prodatqc%nvstpmpp(inrc,1), & 
    592                &                    prodatqc%nvstpmpp(inrc,2) 
     546            WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 
     547            DO jvar = 1, prodatqc%nvar 
     548               WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 
     549            END DO 
     550            WRITE(numout,*) cout1 
    593551         END DO 
    594552      ENDIF 
    595  
    596 998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 
    597 999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    598553 
    599554   END SUBROUTINE obs_pre_prof 
Note: See TracChangeset for help on using the changeset viewer.