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 15670 – NEMO

Changeset 15670


Ignore:
Timestamp:
2022-01-25T15:20:24+01:00 (2 years ago)
Author:
petesykes
Message:

Adding PS45 AMM7 changes

Location:
branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC
Files:
9 added
20 deleted
23 edited

Legend:

Unmodified
Added
Removed

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r10728 r15670  
    7676   LOGICAL, PUBLIC :: ln_trainc = .FALSE.      !: No tracer (T and S) assimilation increments 
    7777   LOGICAL, PUBLIC :: ln_dyninc = .FALSE.      !: No dynamics (u and v) assimilation increments 
     78   LOGICAL, PUBLIC :: ln_ssh_hs_cons = .FALSE. !: Conserve heat and salt when adding SSH increment 
    7879   LOGICAL, PUBLIC :: ln_sshinc = .FALSE.      !: No sea surface height assimilation increment 
    7980   LOGICAL, PUBLIC :: ln_seaiceinc             !: No sea ice concentration increment 
    … …  
    8889   REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   u_bkginc, v_bkginc   !: Increment to the u- & v-components  
    8990   REAL(wp), PUBLIC, DIMENSION(:)    , ALLOCATABLE ::   wgtiau               !: IAU weights for each time step 
    90 #if defined key_asminc 
    9191   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ssh_iau           !: IAU-weighted sea surface height increment 
    92 #endif 
    9392   !                                !!! time steps relative to the cycle interval [0,nitend-nit000-1] 
    9493   INTEGER , PUBLIC ::   nitbkg      !: Time step of the background state used in the Jb term 
    … …  
    173172         &                 ln_pno3inc, ln_psi4inc, ln_pdicinc, ln_palkinc, & 
    174173         &                 ln_pphinc, ln_po2inc, ln_ppo4inc,               & 
    175          &                 ln_asmdin, ln_asmiau,                           & 
     174         &                 ln_asmdin, ln_asmiau, ln_ssh_hs_cons,           & 
    176175         &                 nitbkg, nitdin, nitiaustr, nitiaufin, niaufn,   & 
    177176         &                 ln_salfix, salfixmin, nn_divdmp, nitavgbkg,     & 
    … …  
    193192      ln_asmiau = .TRUE. 
    194193      ln_salfix = .FALSE. 
     194      ln_ssh_hs_cons = .FALSE. 
    195195      ln_temnofreeze = .FALSE. 
    196196      salfixmin = -9999 
    … …  
    222222         WRITE(numout,*) '      Logical switch for applying tracer increments            ln_trainc = ', ln_trainc 
    223223         WRITE(numout,*) '      Logical switch for applying velocity increments          ln_dyninc = ', ln_dyninc 
     224         WRITE(numout,*) '      Logical switch for conserving heat/salt when applying SSH increments ln_ssh_hs_cons = ', ln_ssh_hs_cons 
    224225         WRITE(numout,*) '      Logical switch for applying SSH increments               ln_sshinc = ', ln_sshinc 
    225226         WRITE(numout,*) '      Logical switch for Direct Initialization (DI)            ln_asmdin = ', ln_asmdin 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/DIA/diaopfoam.F90

    r10390 r15670  
    1515   USE diurnal_bulk 
    1616   USE cool_skin 
     17#if defined key_fabm 
     18   USE par_fabm 
     19   USE fabm, ONLY: fabm_get_bulk_diagnostic_data 
     20#endif 
    1721 
    1822 
    … …  
    109113         CALL iom_put( "voce_op"   , vn                                    )    ! j-current 
    110114         !CALL iom_put( "woce_op"   , wn                                    )    ! k-current 
     115#if defined key_spm 
     116         cltra = TRIM(ctrc3d(5))//"_op" 
     117         zw3d(:,:,:) = trc3d(:,:,:,5)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) ! Visibility 
     118         CALL iom_put( cltra, zw3d  ) 
     119#endif 
     120#if defined key_fabm 
     121         zw3d(:,:,:) = (1.7/fabm_get_bulk_diagnostic_data(model, jp_fabm_xeps))*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) ! hourly visibility 
     122         CALL iom_put( "Visib_op" , zw3d(:,:,:)                            ) ! hourly visibility 
     123#endif 
    111124         CALL calc_max_cur(zwu,zwv,zwz,zmdi) 
    112125         CALL iom_put( "maxu" , zwu                                     ) ! max u current 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

    r8058 r15670  
    66   !!====================================================================== 
    77 
    8    !!---------------------------------------------------------------------- 
    9    !!   'key_diaobs' : Switch on the observation diagnostic computation 
    108   !!---------------------------------------------------------------------- 
    119   !!   dia_obs_init : Reading and prepare observations 
    … …  
    1513   !!   fin_date     : Compute the final date YYYYMMDD.HHMMSS 
    1614   !!---------------------------------------------------------------------- 
    17    !! * Modules used    
     15   !! * Modules used 
    1816   USE wrk_nemo                 ! Memory Allocation 
    1917   USE par_kind                 ! Precision variables 
    … …  
    2119   USE par_oce 
    2220   USE dom_oce                  ! Ocean space and time domain variables 
    23    USE obs_fbm, ONLY: ln_cl4    ! Class 4 diagnostic switch 
    24    USE obs_read_prof            ! Reading and allocation of observations (Coriolis) 
    25    USE obs_read_sla             ! Reading and allocation of SLA observations   
    26    USE obs_read_sst             ! Reading and allocation of SST observations   
     21   USE obs_read_prof            ! Reading and allocation of profile obs 
     22   USE obs_read_surf            ! Reading and allocation of surface obs 
    2723   USE obs_readmdt              ! Reading and allocation of MDT for SLA. 
    28    USE obs_read_seaice          ! Reading and allocation of Sea Ice observations   
    29    USE obs_read_vel             ! Reading and allocation of velocity component observations 
    3024   USE obs_prep                 ! Preparation of obs. (grid search etc). 
    3125   USE obs_oper                 ! Observation operators 
    … …  
    3327   USE obs_grid                 ! Grid searching 
    3428   USE obs_read_altbias         ! Bias treatment for altimeter 
     29   USE obs_sstbias              ! Bias correction routine for SST 
    3530   USE obs_profiles_def         ! Profile data definitions 
    36    USE obs_profiles             ! Profile data storage 
    3731   USE obs_surf_def             ! Surface data definitions 
    38    USE obs_sla                  ! SLA data storage 
    39    USE obs_sst                  ! SST data storage 
    40    USE obs_seaice               ! Sea Ice data storage 
    4132   USE obs_types                ! Definitions for observation types 
    4233   USE mpp_map                  ! MPP mapping 
    4334   USE lib_mpp                  ! For ctl_warn/stop 
     35   USE tradmp                   ! For climatological temperature & salinity 
    4436 
    4537   IMPLICIT NONE 
    … …  
    5244      &   dia_obs_dealloc  ! Deallocate dia_obs data 
    5345 
    54    !! * Shared Module variables 
    55    LOGICAL, PUBLIC, PARAMETER :: & 
    56 #if defined key_diaobs 
    57       & lk_diaobs = .TRUE.   !: Logical switch for observation diangostics 
    58 #else 
    59       & lk_diaobs = .FALSE.  !: Logical switch for observation diangostics 
    60 #endif 
    61  
    6246   !! * Module variables 
    63    LOGICAL, PUBLIC :: ln_t3d         !: Logical switch for temperature profiles 
    64    LOGICAL, PUBLIC :: ln_s3d         !: Logical switch for salinity profiles 
    65    LOGICAL, PUBLIC :: ln_ena         !: Logical switch for the ENACT data set 
    66    LOGICAL, PUBLIC :: ln_cor         !: Logical switch for the Coriolis data set 
    67    LOGICAL, PUBLIC :: ln_profb       !: Logical switch for profile feedback datafiles 
    68    LOGICAL, PUBLIC :: ln_sla         !: Logical switch for sea level anomalies  
    69    LOGICAL, PUBLIC :: ln_sladt       !: Logical switch for SLA from AVISO files 
    70    LOGICAL, PUBLIC :: ln_slafb       !: Logical switch for SLA from feedback files 
    71    LOGICAL, PUBLIC :: ln_sst         !: Logical switch for sea surface temperature 
    72    LOGICAL, PUBLIC :: ln_reysst      !: Logical switch for Reynolds sea surface temperature 
    73    LOGICAL, PUBLIC :: ln_ghrsst      !: Logical switch for GHRSST data 
    74    LOGICAL, PUBLIC :: ln_sstfb       !: Logical switch for SST from feedback files 
    75    LOGICAL, PUBLIC :: ln_seaice      !: Logical switch for sea ice concentration 
    76    LOGICAL, PUBLIC :: ln_vel3d       !: Logical switch for velocity component (u,v) observations 
    77    LOGICAL, PUBLIC :: ln_velavcur    !: Logical switch for raw daily averaged netCDF current meter vel. data  
    78    LOGICAL, PUBLIC :: ln_velhrcur    !: Logical switch for raw high freq netCDF current meter vel. data  
    79    LOGICAL, PUBLIC :: ln_velavadcp   !: Logical switch for raw daily averaged netCDF ADCP vel. data  
    80    LOGICAL, PUBLIC :: ln_velhradcp   !: Logical switch for raw high freq netCDF ADCP vel. data  
    81    LOGICAL, PUBLIC :: ln_velfb       !: Logical switch for velocities from feedback files 
    82    LOGICAL, PUBLIC :: ln_ssh         !: Logical switch for sea surface height 
    83    LOGICAL, PUBLIC :: ln_sss         !: Logical switch for sea surface salinity 
    84    LOGICAL, PUBLIC :: ln_sstnight    !: Logical switch for night mean SST observations 
    85    LOGICAL, PUBLIC :: ln_nea         !: Remove observations near land 
    86    LOGICAL, PUBLIC :: ln_altbias     !: Logical switch for altimeter bias   
    87    LOGICAL, PUBLIC :: ln_ignmis      !: Logical switch for ignoring missing files 
    88    LOGICAL, PUBLIC :: ln_s_at_t      !: Logical switch to compute model S at T observations 
    89  
    90    REAL(KIND=dp), PUBLIC :: dobsini   !: Observation window start date YYYYMMDD.HHMMSS 
    91    REAL(KIND=dp), PUBLIC :: dobsend   !: Observation window end date YYYYMMDD.HHMMSS 
    92    
    93    INTEGER, PUBLIC :: n1dint       !: Vertical interpolation method 
    94    INTEGER, PUBLIC :: n2dint       !: Horizontal interpolation method  
    95  
     47   LOGICAL, PUBLIC :: & 
     48      &       lk_diaobs = .TRUE.   !: Include this for backwards compatibility at NEMO 3.6. 
     49   LOGICAL :: ln_diaobs            !: Logical switch for the obs operator 
     50   LOGICAL :: ln_sstnight          !: Logical switch for night mean SST obs 
     51   LOGICAL :: ln_default_fp_indegs !: T=> Default obs footprint size specified in degrees, F=> in metres 
     52   LOGICAL :: ln_sla_fp_indegs     !: T=>     SLA obs footprint size specified in degrees, F=> in metres 
     53   LOGICAL :: ln_sst_fp_indegs     !: T=>     SST obs footprint size specified in degrees, F=> in metres 
     54   LOGICAL :: ln_sss_fp_indegs     !: T=>     SSS obs footprint size specified in degrees, F=> in metres 
     55   LOGICAL :: ln_sic_fp_indegs     !: T=> sea-ice obs footprint size specified in degrees, F=> in metres 
     56   LOGICAL :: ln_output_clim       !: Logical switch for interpolating and writing T/S climatology 
     57   LOGICAL :: ln_time_mean_sla_bkg !: Logical switch for applying time mean of SLA background to remove tidal signal 
     58 
     59   REAL(wp) :: rn_default_avglamscl !: Default E/W diameter of observation footprint 
     60   REAL(wp) :: rn_default_avgphiscl !: Default N/S diameter of observation footprint 
     61   REAL(wp) :: rn_sla_avglamscl     !: E/W diameter of SLA observation footprint 
     62   REAL(wp) :: rn_sla_avgphiscl     !: N/S diameter of SLA observation footprint 
     63   REAL(wp) :: rn_sst_avglamscl     !: E/W diameter of SST observation footprint 
     64   REAL(wp) :: rn_sst_avgphiscl     !: N/S diameter of SST observation footprint 
     65   REAL(wp) :: rn_sss_avglamscl     !: E/W diameter of SSS observation footprint 
     66   REAL(wp) :: rn_sss_avgphiscl     !: N/S diameter of SSS observation footprint 
     67   REAL(wp) :: rn_sic_avglamscl     !: E/W diameter of sea-ice observation footprint 
     68   REAL(wp) :: rn_sic_avgphiscl     !: N/S diameter of sea-ice observation footprint 
     69   REAL(wp), PUBLIC :: & 
     70      &        MeanPeriodHours = 24. + (5./6.) !: Meaning period for surface data. 
     71 
     72 
     73   INTEGER :: nn_1dint         !: Vertical interpolation method 
     74   INTEGER :: nn_2dint_default !: Default horizontal interpolation method 
     75   INTEGER :: nn_2dint_sla     !: SLA horizontal interpolation method (-1 = default) 
     76   INTEGER :: nn_2dint_sst     !: SST horizontal interpolation method (-1 = default) 
     77   INTEGER :: nn_2dint_sss     !: SSS horizontal interpolation method (-1 = default) 
     78   INTEGER :: nn_2dint_sic     !: Seaice horizontal interpolation method (-1 = default) 
     79  
    9680   INTEGER, DIMENSION(imaxavtypes) :: & 
    97       & endailyavtypes !: ENACT data types which are daily average 
    98  
    99    INTEGER, PARAMETER :: MaxNumFiles = 1000 
    100    LOGICAL, DIMENSION(MaxNumFiles) :: & 
    101       & ln_profb_ena, & !: Is the feedback files from ENACT data ? 
    102    !                    !: If so use endailyavtypes 
    103       & ln_profb_enatim !: Change tim for 820 enact data set. 
    104     
    105    LOGICAL, DIMENSION(MaxNumFiles) :: & 
    106       & ln_velfb_av   !: Is the velocity feedback files daily average? 
     81      & nn_profdavtypes      !: Profile data types representing a daily average 
     82   INTEGER :: nproftypes     !: Number of profile obs types 
     83   INTEGER :: nsurftypes     !: Number of surface obs types 
     84   INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     85      & nvarsprof, &         !: Number of profile variables 
     86      & nvarssurf            !: Number of surface variables 
     87   INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     88      & nextrprof, &         !: Number of profile extra variables 
     89      & nextrsurf            !: Number of surface extra variables 
     90   INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     91      & n2dintsurf           !: Interpolation option for surface variables 
     92   REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
     93      & ravglamscl, &        !: E/W diameter of averaging footprint for surface variables 
     94      & ravgphiscl           !: N/S diameter of averaging footprint for surface variables 
    10795   LOGICAL, DIMENSION(:), ALLOCATABLE :: & 
    108       & ld_enact     !: Profile data is ENACT so use endailyavtypes 
    109    LOGICAL, DIMENSION(:), ALLOCATABLE :: & 
    110       & ld_velav     !: Velocity data is daily averaged 
    111    LOGICAL, DIMENSION(:), ALLOCATABLE :: & 
    112       & ld_sstnight  !: SST observation corresponds to night mean 
     96      & lfpindegs, &         !: T=> surface obs footprint size specified in degrees, F=> in metres 
     97      & llnightav            !: Logical for calculating night-time averages 
     98 
     99   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: & 
     100      & surfdata, &          !: Initial surface data 
     101      & surfdataqc           !: Surface data after quality control 
     102   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: & 
     103      & profdata, &          !: Initial profile data 
     104      & profdataqc           !: Profile data after quality control 
     105 
     106   CHARACTER(len=8), PUBLIC, DIMENSION(:), ALLOCATABLE :: & 
     107      & cobstypesprof, &     !: Profile obs types 
     108      & cobstypessurf        !: Surface obs types 
    113109 
    114110   !!---------------------------------------------------------------------- 
    … …  
    118114   !!---------------------------------------------------------------------- 
    119115 
     116   !! * Substitutions  
     117#  include "domzgr_substitute.h90" 
    120118CONTAINS 
    121119 
    … …  
    135133      !!        !  06-10  (A. Weaver) Cleaning and add controls 
    136134      !!        !  07-03  (K. Mogensen) General handling of profiles 
     135      !!        !  14-08  (J.While) Incorporated SST bias correction 
     136      !!        !  15-02  (M. Martin) Simplification of namelist and code 
    137137      !!---------------------------------------------------------------------- 
    138138 
    … …  
    140140 
    141141      !! * Local declarations 
    142       CHARACTER(len=128) :: enactfiles(MaxNumFiles) 
    143       CHARACTER(len=128) :: coriofiles(MaxNumFiles) 
    144       CHARACTER(len=128) :: profbfiles(MaxNumFiles) 
    145       CHARACTER(len=128) :: sstfiles(MaxNumFiles)       
    146       CHARACTER(len=128) :: sstfbfiles(MaxNumFiles)  
    147       CHARACTER(len=128) :: slafilesact(MaxNumFiles)       
    148       CHARACTER(len=128) :: slafilespas(MaxNumFiles)       
    149       CHARACTER(len=128) :: slafbfiles(MaxNumFiles) 
    150       CHARACTER(len=128) :: seaicefiles(MaxNumFiles)            
    151       CHARACTER(len=128) :: velcurfiles(MaxNumFiles)   
    152       CHARACTER(len=128) :: veladcpfiles(MaxNumFiles)     
    153       CHARACTER(len=128) :: velavcurfiles(MaxNumFiles) 
    154       CHARACTER(len=128) :: velhrcurfiles(MaxNumFiles) 
    155       CHARACTER(len=128) :: velavadcpfiles(MaxNumFiles) 
    156       CHARACTER(len=128) :: velhradcpfiles(MaxNumFiles) 
    157       CHARACTER(len=128) :: velfbfiles(MaxNumFiles) 
    158       CHARACTER(LEN=128) :: reysstname 
    159       CHARACTER(LEN=12)  :: reysstfmt 
    160       CHARACTER(LEN=128) :: bias_file 
    161       CHARACTER(LEN=20)  :: datestr=" ", timestr=" " 
    162       NAMELIST/namobs/ln_ena, ln_cor, ln_profb, ln_t3d, ln_s3d,       & 
    163          &            ln_sla, ln_sladt, ln_slafb,                     & 
    164          &            ln_ssh, ln_sst, ln_sstfb, ln_sss, ln_nea,       & 
    165          &            enactfiles, coriofiles, profbfiles,             & 
    166          &            slafilesact, slafilespas, slafbfiles,           & 
    167          &            sstfiles, sstfbfiles,                           & 
    168          &            ln_seaice, seaicefiles,                         & 
    169          &            dobsini, dobsend, n1dint, n2dint,               & 
    170          &            nmsshc, mdtcorr, mdtcutoff,                     & 
    171          &            ln_reysst, ln_ghrsst, reysstname, reysstfmt,    & 
    172          &            ln_sstnight,                                    & 
    173          &            ln_grid_search_lookup,                          & 
    174          &            grid_search_file, grid_search_res,              & 
    175          &            ln_grid_global, bias_file, ln_altbias,          & 
    176          &            endailyavtypes, ln_s_at_t, ln_profb_ena,        & 
    177          &            ln_vel3d, ln_velavcur, velavcurfiles,           & 
    178          &            ln_velhrcur, velhrcurfiles,                     & 
    179          &            ln_velavadcp, velavadcpfiles,                   & 
    180          &            ln_velhradcp, velhradcpfiles,                   & 
    181          &            ln_velfb, velfbfiles, ln_velfb_av,              & 
    182          &            ln_profb_enatim, ln_ignmis, ln_cl4 
    183  
    184       INTEGER :: jprofset 
    185       INTEGER :: jveloset 
    186       INTEGER :: jvar 
    187       INTEGER :: jnumenact 
    188       INTEGER :: jnumcorio 
    189       INTEGER :: jnumprofb 
    190       INTEGER :: jnumslaact 
    191       INTEGER :: jnumslapas 
    192       INTEGER :: jnumslafb 
    193       INTEGER :: jnumsst 
    194       INTEGER :: jnumsstfb 
    195       INTEGER :: jnumseaice 
    196       INTEGER :: jnumvelavcur 
    197       INTEGER :: jnumvelhrcur   
    198       INTEGER :: jnumvelavadcp 
    199       INTEGER :: jnumvelhradcp    
    200       INTEGER :: jnumvelfb 
    201       INTEGER :: ji 
    202       INTEGER :: jset 
    203       INTEGER :: ios                 ! Local integer output status for namelist read 
    204       LOGICAL :: lmask(MaxNumFiles), ll_u3d, ll_v3d 
     142      INTEGER, PARAMETER :: & 
     143         & jpmaxnfiles = 1000    ! Maximum number of files for each obs type 
     144      INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     145         & ifilesprof, &         ! Number of profile files 
     146         & ifilessurf            ! Number of surface files 
     147      INTEGER :: ios             ! Local integer output status for namelist read 
     148      INTEGER :: jtype           ! Counter for obs types 
     149      INTEGER :: jvar            ! Counter for variables 
     150      INTEGER :: jfile           ! Counter for files 
     151      INTEGER :: jnumsstbias     ! Number of SST bias files to read and apply 
     152      INTEGER :: n2dint_type     ! Local version of nn_2dint* 
     153 
     154      CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 
     155         & cn_profbfiles,      & ! T/S profile input filenames 
     156         & cn_sstfbfiles,      & ! Sea surface temperature input filenames 
     157         & cn_slafbfiles,      & ! Sea level anomaly input filenames 
     158         & cn_sicfbfiles,      & ! Seaice concentration input filenames 
     159         & cn_velfbfiles,      & ! Velocity profile input filenames 
     160         & cn_sssfbfiles,      & ! Sea surface salinity input filenames 
     161         & cn_slchltotfbfiles, & ! Surface total              log10(chlorophyll) input filenames 
     162         & cn_slchldiafbfiles, & ! Surface diatom             log10(chlorophyll) input filenames 
     163         & cn_slchlnonfbfiles, & ! Surface non-diatom         log10(chlorophyll) input filenames 
     164         & cn_slchldinfbfiles, & ! Surface dinoflagellate     log10(chlorophyll) input filenames 
     165         & cn_slchlmicfbfiles, & ! Surface microphytoplankton log10(chlorophyll) input filenames 
     166         & cn_slchlnanfbfiles, & ! Surface nanophytoplankton  log10(chlorophyll) input filenames 
     167         & cn_slchlpicfbfiles, & ! Surface picophytoplankton  log10(chlorophyll) input filenames 
     168         & cn_schltotfbfiles,  & ! Surface total              chlorophyll        input filenames 
     169         & cn_slphytotfbfiles, & ! Surface total      log10(phytoplankton carbon) input filenames 
     170         & cn_slphydiafbfiles, & ! Surface diatom     log10(phytoplankton carbon) input filenames 
     171         & cn_slphynonfbfiles, & ! Surface non-diatom log10(phytoplankton carbon) input filenames 
     172         & cn_sspmfbfiles,     & ! Surface suspended particulate matter input filenames 
     173         & cn_skd490fbfiles,   & ! Surface Kd490 input filenames 
     174         & cn_sfco2fbfiles,    & ! Surface fugacity         of carbon dioxide input filenames 
     175         & cn_spco2fbfiles,    & ! Surface partial pressure of carbon dioxide input filenames 
     176         & cn_plchltotfbfiles, & ! Profile total log10(chlorophyll) input filenames 
     177         & cn_pchltotfbfiles,  & ! Profile total chlorophyll input filenames 
     178         & cn_pno3fbfiles,     & ! Profile nitrate input filenames 
     179         & cn_psi4fbfiles,     & ! Profile silicate input filenames 
     180         & cn_ppo4fbfiles,     & ! Profile phosphate input filenames 
     181         & cn_pdicfbfiles,     & ! Profile dissolved inorganic carbon input filenames 
     182         & cn_palkfbfiles,     & ! Profile alkalinity input filenames 
     183         & cn_pphfbfiles,      & ! Profile pH input filenames 
     184         & cn_po2fbfiles,      & ! Profile dissolved oxygen input filenames 
     185         & cn_sstbiasfiles       ! SST bias input filenames 
     186 
     187      CHARACTER(LEN=128) :: & 
     188         & cn_altbiasfile        ! Altimeter bias input filename 
     189 
     190 
     191      LOGICAL :: ln_t3d          ! Logical switch for temperature profiles 
     192      LOGICAL :: ln_s3d          ! Logical switch for salinity profiles 
     193      LOGICAL :: ln_sla          ! Logical switch for sea level anomalies  
     194      LOGICAL :: ln_sst          ! Logical switch for sea surface temperature 
     195      LOGICAL :: ln_sic          ! Logical switch for sea ice concentration 
     196      LOGICAL :: ln_sss          ! Logical switch for sea surface salinity obs 
     197      LOGICAL :: ln_vel3d        ! Logical switch for velocity (u,v) obs 
     198      LOGICAL :: ln_slchltot     ! Logical switch for surface total              log10(chlorophyll) obs 
     199      LOGICAL :: ln_slchldia     ! Logical switch for surface diatom             log10(chlorophyll) obs 
     200      LOGICAL :: ln_slchlnon     ! Logical switch for surface non-diatom         log10(chlorophyll) obs 
     201      LOGICAL :: ln_slchldin     ! Logical switch for surface dinoflagellate     log10(chlorophyll) obs 
     202      LOGICAL :: ln_slchlmic     ! Logical switch for surface microphytoplankton log10(chlorophyll) obs 
     203      LOGICAL :: ln_slchlnan     ! Logical switch for surface nanophytoplankton  log10(chlorophyll) obs 
     204      LOGICAL :: ln_slchlpic     ! Logical switch for surface picophytoplankton  log10(chlorophyll) obs 
     205      LOGICAL :: ln_schltot      ! Logical switch for surface total              chlorophyll        obs 
     206      LOGICAL :: ln_slphytot     ! Logical switch for surface total      log10(phytoplankton carbon) obs 
     207      LOGICAL :: ln_slphydia     ! Logical switch for surface diatom     log10(phytoplankton carbon) obs 
     208      LOGICAL :: ln_slphynon     ! Logical switch for surface non-diatom log10(phytoplankton carbon) obs 
     209      LOGICAL :: ln_sspm         ! Logical switch for surface suspended particulate matter obs 
     210      LOGICAL :: ln_skd490       ! Logical switch for surface Kd490 
     211      LOGICAL :: ln_sfco2        ! Logical switch for surface fugacity         of carbon dioxide obs 
     212      LOGICAL :: ln_spco2        ! Logical switch for surface partial pressure of carbon dioxide obs 
     213      LOGICAL :: ln_plchltot     ! Logical switch for profile total log10(chlorophyll) obs 
     214      LOGICAL :: ln_pchltot      ! Logical switch for profile total chlorophyll obs 
     215      LOGICAL :: ln_pno3         ! Logical switch for profile nitrate obs 
     216      LOGICAL :: ln_psi4         ! Logical switch for profile silicate obs 
     217      LOGICAL :: ln_ppo4         ! Logical switch for profile phosphate obs 
     218      LOGICAL :: ln_pdic         ! Logical switch for profile dissolved inorganic carbon obs 
     219      LOGICAL :: ln_palk         ! Logical switch for profile alkalinity obs 
     220      LOGICAL :: ln_pph          ! Logical switch for profile pH obs 
     221      LOGICAL :: ln_po2          ! Logical switch for profile dissolved oxygen obs 
     222      LOGICAL :: ln_nea          ! Logical switch to remove obs near land 
     223      LOGICAL :: ln_altbias      ! Logical switch for altimeter bias 
     224      LOGICAL :: ln_sstbias      ! Logical switch for bias correction of SST 
     225      LOGICAL :: ln_ignmis       ! Logical switch for ignoring missing files 
     226      LOGICAL :: ln_s_at_t       ! Logical switch to compute model S at T obs 
     227      LOGICAL :: ln_bound_reject ! Logical switch for rejecting obs near the boundary 
     228 
     229      REAL(dp) :: rn_dobsini     ! Obs window start date YYYYMMDD.HHMMSS 
     230      REAL(dp) :: rn_dobsend     ! Obs window end date   YYYYMMDD.HHMMSS 
     231 
     232      REAL(wp) :: ztype_avglamscl ! Local version of rn_*_avglamscl 
     233      REAL(wp) :: ztype_avgphiscl ! Local version of rn_*_avgphiscl 
     234 
     235      CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 
     236         & clproffiles, &        ! Profile filenames 
     237         & clsurffiles           ! Surface filenames 
     238      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars  ! Expected variable names 
     239 
     240      LOGICAL, DIMENSION(:), ALLOCATABLE :: llvar   ! Logical for profile variable read 
     241      LOGICAL :: ltype_fp_indegs ! Local version of ln_*_fp_indegs 
     242      LOGICAL :: ltype_night     ! Local version of ln_sstnight (false for other variables) 
     243      LOGICAL :: ltype_clim      ! Local version of ln_output_clim 
     244 
     245      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     246         & zglam                 ! Model longitudes for profile variables 
     247      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     248         & zgphi                 ! Model latitudes for profile variables 
     249      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: & 
     250         & zmask                 ! Model land/sea mask associated with variables 
     251 
     252 
     253      NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla,              & 
     254         &            ln_sst, ln_sic, ln_sss, ln_vel3d,               & 
     255         &            ln_slchltot, ln_slchldia, ln_slchlnon,          & 
     256         &            ln_slchldin, ln_slchlmic, ln_slchlnan,          & 
     257         &            ln_slchlpic, ln_schltot,                        & 
     258         &            ln_slphytot, ln_slphydia, ln_slphynon,          & 
     259         &            ln_sspm,     ln_sfco2,    ln_spco2,             & 
     260         &            ln_skd490,                                      & 
     261         &            ln_plchltot, ln_pchltot,  ln_pno3,              & 
     262         &            ln_psi4,     ln_ppo4,     ln_pdic,              & 
     263         &            ln_palk,     ln_pph,      ln_po2,               & 
     264         &            ln_altbias, ln_sstbias, ln_nea,                 & 
     265         &            ln_grid_global, ln_grid_search_lookup,          & 
     266         &            ln_ignmis, ln_s_at_t, ln_bound_reject,          & 
     267         &            ln_sstnight,  ln_output_clim,                   & 
     268         &            ln_time_mean_sla_bkg, ln_default_fp_indegs,     & 
     269         &            ln_sla_fp_indegs, ln_sst_fp_indegs,             & 
     270         &            ln_sss_fp_indegs, ln_sic_fp_indegs,             & 
     271         &            cn_profbfiles, cn_slafbfiles,                   & 
     272         &            cn_sstfbfiles, cn_sicfbfiles,                   & 
     273         &            cn_velfbfiles, cn_sssfbfiles,                   & 
     274         &            cn_slchltotfbfiles, cn_slchldiafbfiles,         & 
     275         &            cn_slchlnonfbfiles, cn_slchldinfbfiles,         & 
     276         &            cn_slchlmicfbfiles, cn_slchlnanfbfiles,         & 
     277         &            cn_slchlpicfbfiles, cn_schltotfbfiles,          & 
     278         &            cn_slphytotfbfiles, cn_slphydiafbfiles,         & 
     279         &            cn_slphynonfbfiles, cn_sspmfbfiles,             & 
     280         &            cn_skd490fbfiles,                               & 
     281         &            cn_sfco2fbfiles, cn_spco2fbfiles,               & 
     282         &            cn_plchltotfbfiles, cn_pchltotfbfiles,          & 
     283         &            cn_pno3fbfiles, cn_psi4fbfiles, cn_ppo4fbfiles, & 
     284         &            cn_pdicfbfiles, cn_palkfbfiles, cn_pphfbfiles,  & 
     285         &            cn_po2fbfiles,                                  & 
     286         &            cn_sstbiasfiles, cn_altbiasfile,                & 
     287         &            cn_gridsearchfile, rn_gridsearchres,            & 
     288         &            rn_dobsini, rn_dobsend,                         & 
     289         &            rn_default_avglamscl, rn_default_avgphiscl,     & 
     290         &            rn_sla_avglamscl, rn_sla_avgphiscl,             & 
     291         &            rn_sst_avglamscl, rn_sst_avgphiscl,             & 
     292         &            rn_sss_avglamscl, rn_sss_avgphiscl,             & 
     293         &            rn_sic_avglamscl, rn_sic_avgphiscl,             & 
     294         &            nn_1dint, nn_2dint_default,                     & 
     295         &            nn_2dint_sla, nn_2dint_sst,                     & 
     296         &            nn_2dint_sss, nn_2dint_sic,                     & 
     297         &            nn_msshc, rn_mdtcorr, rn_mdtcutoff,             & 
     298         &            nn_profdavtypes 
    205299 
    206300      !----------------------------------------------------------------------- 
    … …  
    208302      !----------------------------------------------------------------------- 
    209303 
    210       enactfiles(:) = '' 
    211       coriofiles(:) = '' 
    212       profbfiles(:) = '' 
    213       slafilesact(:) = '' 
    214       slafilespas(:) = '' 
    215       slafbfiles(:) = '' 
    216       sstfiles(:)   = '' 
    217       sstfbfiles(:) = '' 
    218       seaicefiles(:) = '' 
    219       velcurfiles(:) = '' 
    220       veladcpfiles(:) = '' 
    221       velavcurfiles(:) = '' 
    222       velhrcurfiles(:) = '' 
    223       velavadcpfiles(:) = '' 
    224       velhradcpfiles(:) = '' 
    225       velfbfiles(:) = '' 
    226       velcurfiles(:) = '' 
    227       veladcpfiles(:) = '' 
    228       endailyavtypes(:) = -1 
    229       endailyavtypes(1) = 820 
    230       ln_profb_ena(:) = .FALSE. 
    231       ln_profb_enatim(:) = .TRUE. 
    232       ln_velfb_av(:) = .FALSE. 
    233       ln_ignmis = .FALSE. 
    234        
    235       CALL ini_date( dobsini ) 
    236       CALL fin_date( dobsend ) 
    237   
    238       ! Read Namelist namobs : control observation diagnostics 
    239       REWIND( numnam_ref )              ! Namelist namobs in reference namelist : Diagnostic: control observation 
     304      ! Some namelist arrays need initialising 
     305      cn_profbfiles(:)      = '' 
     306      cn_slafbfiles(:)      = '' 
     307      cn_sstfbfiles(:)      = '' 
     308      cn_sicfbfiles(:)      = '' 
     309      cn_velfbfiles(:)      = '' 
     310      cn_sssfbfiles(:)      = '' 
     311      cn_slchltotfbfiles(:) = '' 
     312      cn_slchldiafbfiles(:) = '' 
     313      cn_slchlnonfbfiles(:) = '' 
     314      cn_slchldinfbfiles(:) = '' 
     315      cn_slchlmicfbfiles(:) = '' 
     316      cn_slchlnanfbfiles(:) = '' 
     317      cn_slchlpicfbfiles(:) = '' 
     318      cn_schltotfbfiles(:)  = '' 
     319      cn_slphytotfbfiles(:) = '' 
     320      cn_slphydiafbfiles(:) = '' 
     321      cn_slphynonfbfiles(:) = '' 
     322      cn_sspmfbfiles(:)     = '' 
     323      cn_skd490fbfiles(:)   = '' 
     324      cn_sfco2fbfiles(:)    = '' 
     325      cn_spco2fbfiles(:)    = '' 
     326      cn_plchltotfbfiles(:) = '' 
     327      cn_pchltotfbfiles(:)  = '' 
     328      cn_pno3fbfiles(:)     = '' 
     329      cn_psi4fbfiles(:)     = '' 
     330      cn_ppo4fbfiles(:)     = '' 
     331      cn_pdicfbfiles(:)     = '' 
     332      cn_palkfbfiles(:)     = '' 
     333      cn_pphfbfiles(:)      = '' 
     334      cn_po2fbfiles(:)      = '' 
     335      cn_sstbiasfiles(:)    = '' 
     336      nn_profdavtypes(:)    = -1 
     337 
     338      CALL ini_date( rn_dobsini ) 
     339      CALL fin_date( rn_dobsend ) 
     340 
     341      ! Read namelist namobs : control observation diagnostics 
     342      REWIND( numnam_ref )   ! Namelist namobs in reference namelist 
    240343      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 
    241344901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 
    242345 
    243       REWIND( numnam_cfg )              ! Namelist namobs in configuration namelist : Diagnostic: control observation 
     346      REWIND( numnam_cfg )   ! Namelist namobs in configuration namelist 
    244347      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 
    245348902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 
    246349      IF(lwm) WRITE ( numond, namobs ) 
    247350 
    248       ! Count number of files for each type 
    249       IF (ln_ena) THEN 
    250          lmask(:) = .FALSE. 
    251          WHERE (enactfiles(:) /= '') lmask(:) = .TRUE. 
    252          jnumenact = COUNT(lmask) 
     351      lk_diaobs = .FALSE. 
     352#if defined key_diaobs 
     353      IF ( ln_diaobs ) lk_diaobs = .TRUE. 
     354#endif 
     355 
     356      IF ( .NOT. lk_diaobs ) THEN 
     357         IF(lwp) WRITE(numout,cform_war) 
     358         IF(lwp) WRITE(numout,*)' ln_diaobs is set to false or key_diaobs is not set, so not calling dia_obs' 
     359         RETURN 
    253360      ENDIF 
    254       IF (ln_cor) THEN 
    255          lmask(:) = .FALSE. 
    256          WHERE (coriofiles(:) /= '') lmask(:) = .TRUE. 
    257          jnumcorio = COUNT(lmask) 
    258       ENDIF 
    259       IF (ln_profb) THEN 
    260          lmask(:) = .FALSE. 
    261          WHERE (profbfiles(:) /= '') lmask(:) = .TRUE. 
    262          jnumprofb = COUNT(lmask) 
    263       ENDIF 
    264       IF (ln_sladt) THEN 
    265          lmask(:) = .FALSE. 
    266          WHERE (slafilesact(:) /= '') lmask(:) = .TRUE. 
    267          jnumslaact = COUNT(lmask) 
    268          lmask(:) = .FALSE. 
    269          WHERE (slafilespas(:) /= '') lmask(:) = .TRUE. 
    270          jnumslapas = COUNT(lmask) 
    271       ENDIF 
    272       IF (ln_slafb) THEN 
    273          lmask(:) = .FALSE. 
    274          WHERE (slafbfiles(:) /= '') lmask(:) = .TRUE. 
    275          jnumslafb = COUNT(lmask) 
    276          lmask(:) = .FALSE. 
    277       ENDIF 
    278       IF (ln_ghrsst) THEN 
    279          lmask(:) = .FALSE. 
    280          WHERE (sstfiles(:) /= '') lmask(:) = .TRUE. 
    281          jnumsst = COUNT(lmask) 
    282       ENDIF       
    283       IF (ln_sstfb) THEN 
    284          lmask(:) = .FALSE. 
    285          WHERE (sstfbfiles(:) /= '') lmask(:) = .TRUE. 
    286          jnumsstfb = COUNT(lmask) 
    287          lmask(:) = .FALSE. 
    288       ENDIF 
    289       IF (ln_seaice) THEN 
    290          lmask(:) = .FALSE. 
    291          WHERE (seaicefiles(:) /= '') lmask(:) = .TRUE. 
    292          jnumseaice = COUNT(lmask) 
    293       ENDIF 
    294       IF (ln_velavcur) THEN 
    295          lmask(:) = .FALSE. 
    296          WHERE (velavcurfiles(:) /= '') lmask(:) = .TRUE. 
    297          jnumvelavcur = COUNT(lmask) 
    298       ENDIF 
    299       IF (ln_velhrcur) THEN 
    300          lmask(:) = .FALSE. 
    301          WHERE (velhrcurfiles(:) /= '') lmask(:) = .TRUE. 
    302          jnumvelhrcur = COUNT(lmask) 
    303       ENDIF 
    304       IF (ln_velavadcp) THEN 
    305          lmask(:) = .FALSE. 
    306          WHERE (velavadcpfiles(:) /= '') lmask(:) = .TRUE. 
    307          jnumvelavadcp = COUNT(lmask) 
    308       ENDIF 
    309       IF (ln_velhradcp) THEN 
    310          lmask(:) = .FALSE. 
    311          WHERE (velhradcpfiles(:) /= '') lmask(:) = .TRUE. 
    312          jnumvelhradcp = COUNT(lmask) 
    313       ENDIF 
    314       IF (ln_velfb) THEN 
    315          lmask(:) = .FALSE. 
    316          WHERE (velfbfiles(:) /= '') lmask(:) = .TRUE. 
    317          jnumvelfb = COUNT(lmask) 
    318          lmask(:) = .FALSE. 
    319       ENDIF 
    320        
    321       ! Control print 
     361 
    322362      IF(lwp) THEN 
    323363         WRITE(numout,*) 
    … …  
    325365         WRITE(numout,*) '~~~~~~~~~~~~' 
    326366         WRITE(numout,*) '          Namelist namobs : set observation diagnostic parameters'  
    327          WRITE(numout,*) '             Logical switch for T profile observations          ln_t3d = ', ln_t3d 
    328          WRITE(numout,*) '             Logical switch for S profile observations          ln_s3d = ', ln_s3d 
    329          WRITE(numout,*) '             Logical switch for ENACT insitu data set           ln_ena = ', ln_ena 
    330          WRITE(numout,*) '             Logical switch for Coriolis insitu data set        ln_cor = ', ln_cor 
    331          WRITE(numout,*) '             Logical switch for feedback insitu data set      ln_profb = ', ln_profb 
    332          WRITE(numout,*) '             Logical switch for SLA observations                ln_sla = ', ln_sla 
    333          WRITE(numout,*) '             Logical switch for AVISO SLA data                ln_sladt = ', ln_sladt 
    334          WRITE(numout,*) '             Logical switch for feedback SLA data             ln_slafb = ', ln_slafb 
    335          WRITE(numout,*) '             Logical switch for SSH observations                ln_ssh = ', ln_ssh 
    336          WRITE(numout,*) '             Logical switch for SST observations                ln_sst = ', ln_sst 
    337          WRITE(numout,*) '             Logical switch for Reynolds observations        ln_reysst = ', ln_reysst     
    338          WRITE(numout,*) '             Logical switch for GHRSST observations          ln_ghrsst = ', ln_ghrsst 
    339          WRITE(numout,*) '             Logical switch for feedback SST data             ln_sstfb = ', ln_sstfb 
    340          WRITE(numout,*) '             Logical switch for night-time SST obs         ln_sstnight = ', ln_sstnight 
    341          WRITE(numout,*) '             Logical switch for SSS observations                ln_sss = ', ln_sss 
    342          WRITE(numout,*) '             Logical switch for Sea Ice observations         ln_seaice = ', ln_seaice 
    343          WRITE(numout,*) '             Logical switch for velocity observations         ln_vel3d = ', ln_vel3d 
    344          WRITE(numout,*) '             Logical switch for velocity daily av. cur.    ln_velavcur = ', ln_velavcur 
    345          WRITE(numout,*) '             Logical switch for velocity high freq. cur.   ln_velhrcur = ', ln_velhrcur 
    346          WRITE(numout,*) '             Logical switch for velocity daily av. ADCP   ln_velavadcp = ', ln_velavadcp 
    347          WRITE(numout,*) '             Logical switch for velocity high freq. ADCP  ln_velhradcp = ', ln_velhradcp 
    348          WRITE(numout,*) '             Logical switch for feedback velocity data        ln_velfb = ', ln_velfb 
    349          WRITE(numout,*) '             Global distribtion of observations         ln_grid_global = ',ln_grid_global 
    350          WRITE(numout,*) & 
    351    '             Logical switch for obs grid search w/lookup table  ln_grid_search_lookup = ',ln_grid_search_lookup 
     367         WRITE(numout,*) '             Logical switch for T profile observations                ln_t3d = ', ln_t3d 
     368         WRITE(numout,*) '             Logical switch for S profile observations                ln_s3d = ', ln_s3d 
     369         WRITE(numout,*) '             Logical switch for SLA observations                      ln_sla = ', ln_sla 
     370         WRITE(numout,*) '             Logical switch for SST observations                      ln_sst = ', ln_sst 
     371         WRITE(numout,*) '             Logical switch for Sea Ice observations                  ln_sic = ', ln_sic 
     372         WRITE(numout,*) '             Logical switch for velocity observations               ln_vel3d = ', ln_vel3d 
     373         WRITE(numout,*) '             Logical switch for SSS observations                      ln_sss = ', ln_sss 
     374         WRITE(numout,*) '             Logical switch for surface total logchl obs         ln_slchltot = ', ln_slchltot 
     375         WRITE(numout,*) '             Logical switch for surface diatom logchl obs        ln_slchldia = ', ln_slchldia 
     376         WRITE(numout,*) '             Logical switch for surface non-diatom logchl obs    ln_slchlnon = ', ln_slchlnon 
     377         WRITE(numout,*) '             Logical switch for surface dino logchl obs          ln_slchldin = ', ln_slchldin 
     378         WRITE(numout,*) '             Logical switch for surface micro logchl obs         ln_slchlmic = ', ln_slchlmic 
     379         WRITE(numout,*) '             Logical switch for surface nano logchl obs          ln_slchlnan = ', ln_slchlnan 
     380         WRITE(numout,*) '             Logical switch for surface pico logchl obs          ln_slchlpic = ', ln_slchlpic 
     381         WRITE(numout,*) '             Logical switch for surface total chl obs             ln_schltot = ', ln_schltot 
     382         WRITE(numout,*) '             Logical switch for surface total log(phyC) obs      ln_slphytot = ', ln_slphytot 
     383         WRITE(numout,*) '             Logical switch for surface diatom log(phyC) obs     ln_slphydia = ', ln_slphydia 
     384         WRITE(numout,*) '             Logical switch for surface non-diatom log(phyC) obs ln_slphynon = ', ln_slphynon 
     385         WRITE(numout,*) '             Logical switch for surface SPM observations             ln_sspm = ', ln_sspm 
     386         WRITE(numout,*) '             Logical switch for surface Kd490 observations         ln_skd490 = ', ln_skd490 
     387         WRITE(numout,*) '             Logical switch for surface fCO2 observations           ln_sfco2 = ', ln_sfco2 
     388         WRITE(numout,*) '             Logical switch for surface pCO2 observations           ln_spco2 = ', ln_spco2 
     389         WRITE(numout,*) '             Logical switch for profile total logchl obs         ln_plchltot = ', ln_plchltot 
     390         WRITE(numout,*) '             Logical switch for profile total chl obs             ln_pchltot = ', ln_pchltot 
     391         WRITE(numout,*) '             Logical switch for profile nitrate obs                  ln_pno3 = ', ln_pno3 
     392         WRITE(numout,*) '             Logical switch for profile silicate obs                 ln_psi4 = ', ln_psi4 
     393         WRITE(numout,*) '             Logical switch for profile phosphate obs                ln_ppo4 = ', ln_ppo4 
     394         WRITE(numout,*) '             Logical switch for profile DIC obs                      ln_pdic = ', ln_pdic 
     395         WRITE(numout,*) '             Logical switch for profile alkalinity obs               ln_palk = ', ln_palk 
     396         WRITE(numout,*) '             Logical switch for profile pH obs                        ln_pph = ', ln_pph 
     397         WRITE(numout,*) '             Logical switch for profile oxygen obs                    ln_po2 = ', ln_po2 
     398         WRITE(numout,*) '             Global distribution of observations              ln_grid_global = ', ln_grid_global 
     399         WRITE(numout,*) '             Logical switch for obs grid search lookup ln_grid_search_lookup = ', ln_grid_search_lookup 
    352400         IF (ln_grid_search_lookup) & 
    353             WRITE(numout,*) '             Grid search lookup file header       grid_search_file = ', grid_search_file 
    354          IF (ln_ena) THEN 
    355             DO ji = 1, jnumenact 
    356                WRITE(numout,'(1X,2A)') '             ENACT input observation file name          enactfiles = ', & 
    357                   TRIM(enactfiles(ji)) 
    358             END DO 
    359          ENDIF 
    360          IF (ln_cor) THEN 
    361             DO ji = 1, jnumcorio 
    362                WRITE(numout,'(1X,2A)') '             Coriolis input observation file name       coriofiles = ', & 
    363                   TRIM(coriofiles(ji)) 
    364             END DO 
    365          ENDIF 
    366          IF (ln_profb) THEN 
    367             DO ji = 1, jnumprofb 
    368                IF (ln_profb_ena(ji)) THEN 
    369                   WRITE(numout,'(1X,2A)') '       Enact feedback input observation file name       profbfiles = ', & 
    370                      TRIM(profbfiles(ji)) 
     401            WRITE(numout,*) '             Grid search lookup file header                cn_gridsearchfile = ', cn_gridsearchfile 
     402         WRITE(numout,*) '             Initial date in window YYYYMMDD.HHMMSS               rn_dobsini = ', rn_dobsini 
     403         WRITE(numout,*) '             Final date in window YYYYMMDD.HHMMSS                 rn_dobsend = ', rn_dobsend 
     404         WRITE(numout,*) '             Type of vertical interpolation method                  nn_1dint = ', nn_1dint 
     405         WRITE(numout,*) '             Default horizontal interpolation method        nn_2dint_default = ', nn_2dint_default 
     406         WRITE(numout,*) '             Type of horizontal interpolation method for SLA    nn_2dint_sla = ', nn_2dint_sla 
     407         WRITE(numout,*) '             Type of horizontal interpolation method for SST    nn_2dint_sst = ', nn_2dint_sst 
     408         WRITE(numout,*) '             Type of horizontal interpolation method for SSS    nn_2dint_sss = ', nn_2dint_sss 
     409         WRITE(numout,*) '             Type of horizontal interpolation method for SIC    nn_2dint_sic = ', nn_2dint_sic 
     410         WRITE(numout,*) '             Default E/W diameter of obs footprint      rn_default_avglamscl = ', rn_default_avglamscl 
     411         WRITE(numout,*) '             Default N/S diameter of obs footprint      rn_default_avgphiscl = ', rn_default_avgphiscl 
     412         WRITE(numout,*) '             Default obs footprint in deg [T] or m [F]  ln_default_fp_indegs = ', ln_default_fp_indegs 
     413         WRITE(numout,*) '             SLA E/W diameter of obs footprint              rn_sla_avglamscl = ', rn_sla_avglamscl 
     414         WRITE(numout,*) '             SLA N/S diameter of obs footprint              rn_sla_avgphiscl = ', rn_sla_avgphiscl 
     415         WRITE(numout,*) '             SLA obs footprint in deg [T] or m [F]          ln_sla_fp_indegs = ', ln_sla_fp_indegs 
     416         WRITE(numout,*) '             SST E/W diameter of obs footprint              rn_sst_avglamscl = ', rn_sst_avglamscl 
     417         WRITE(numout,*) '             SST N/S diameter of obs footprint              rn_sst_avgphiscl = ', rn_sst_avgphiscl 
     418         WRITE(numout,*) '             SST obs footprint in deg [T] or m [F]          ln_sst_fp_indegs = ', ln_sst_fp_indegs 
     419         WRITE(numout,*) '             SIC E/W diameter of obs footprint              rn_sic_avglamscl = ', rn_sic_avglamscl 
     420         WRITE(numout,*) '             SIC N/S diameter of obs footprint              rn_sic_avgphiscl = ', rn_sic_avgphiscl 
     421         WRITE(numout,*) '             SIC obs footprint in deg [T] or m [F]          ln_sic_fp_indegs = ', ln_sic_fp_indegs 
     422         WRITE(numout,*) '             Rejection of observations near land switch               ln_nea = ', ln_nea 
     423         WRITE(numout,*) '             Rejection of obs near open bdys                 ln_bound_reject = ', ln_bound_reject 
     424         WRITE(numout,*) '             MSSH correction scheme                                 nn_msshc = ', nn_msshc 
     425         WRITE(numout,*) '             MDT  correction                                      rn_mdtcorr = ', rn_mdtcorr 
     426         WRITE(numout,*) '             MDT cutoff for computed correction                 rn_mdtcutoff = ', rn_mdtcutoff 
     427         WRITE(numout,*) '             Logical switch for alt bias                          ln_altbias = ', ln_altbias 
     428         WRITE(numout,*) '             Logical switch for sst bias                          ln_sstbias = ', ln_sstbias 
     429         WRITE(numout,*) '             Logical switch for ignoring missing files             ln_ignmis = ', ln_ignmis 
     430         WRITE(numout,*) '             Daily average types                             nn_profdavtypes = ', nn_profdavtypes 
     431         WRITE(numout,*) '             Logical switch for night-time SST obs               ln_sstnight = ', ln_sstnight 
     432         WRITE(numout,*) '             Logical switch for writing climat. at obs points ln_output_clim = ', ln_output_clim 
     433         WRITE(numout,*) '             Logical switch for time-mean of SLA        ln_time_mean_sla_bkg = ', ln_time_mean_sla_bkg 
     434      ENDIF 
     435      !----------------------------------------------------------------------- 
     436      ! Set up list of observation types to be used 
     437      ! and the files associated with each type 
     438      !----------------------------------------------------------------------- 
     439 
     440      nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d, ln_plchltot,          & 
     441         &                  ln_pchltot,  ln_pno3,     ln_psi4,     ln_ppo4,     & 
     442         &                  ln_pdic,     ln_palk,     ln_pph,      ln_po2 /) ) 
     443      nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic, ln_sss,                     & 
     444         &                  ln_slchltot, ln_slchldia, ln_slchlnon, ln_slchldin, & 
     445         &                  ln_slchlmic, ln_slchlnan, ln_slchlpic, ln_schltot,  & 
     446         &                  ln_slphytot, ln_slphydia, ln_slphynon, ln_sspm,     & 
     447         &                  ln_skd490,   ln_sfco2,    ln_spco2 /) ) 
     448 
     449      IF ( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 
     450         IF(lwp) WRITE(numout,cform_war) 
     451         IF(lwp) WRITE(numout,*) ' ln_diaobs is set to true, but all obs operator logical flags', & 
     452            &                    ' are set to .FALSE. so turning off calls to dia_obs' 
     453         nwarn = nwarn + 1 
     454         lk_diaobs = .FALSE. 
     455         RETURN 
     456      ENDIF 
     457 
     458      IF ( ln_output_clim .AND. ( .NOT. ln_tradmp ) ) THEN 
     459         IF(lwp) WRITE(numout,cform_war) 
     460         IF(lwp) WRITE(numout,*) ' ln_output_clim is true, but ln_tradmp is false', & 
     461            &                    ' so climatological T/S not available and will not be output' 
     462         nwarn = nwarn + 1 
     463         ln_output_clim = .FALSE. 
     464      ENDIF 
     465      
     466 
     467      IF(lwp) WRITE(numout,*) '          Number of profile obs types: ',nproftypes 
     468      IF ( nproftypes > 0 ) THEN 
     469 
     470         ALLOCATE( cobstypesprof(nproftypes) ) 
     471         ALLOCATE( ifilesprof(nproftypes) ) 
     472         ALLOCATE( clproffiles(nproftypes,jpmaxnfiles) ) 
     473 
     474         jtype = 0 
     475         IF (ln_t3d .OR. ln_s3d) THEN 
     476            jtype = jtype + 1 
     477            cobstypesprof(jtype) = 'prof' 
     478            clproffiles(jtype,:) = cn_profbfiles 
     479         ENDIF 
     480         IF (ln_vel3d) THEN 
     481            jtype = jtype + 1 
     482            cobstypesprof(jtype) =  'vel' 
     483            clproffiles(jtype,:) = cn_velfbfiles 
     484         ENDIF 
     485         IF (ln_plchltot) THEN 
     486            jtype = jtype + 1 
     487            cobstypesprof(jtype) = 'plchltot' 
     488            clproffiles(jtype,:) = cn_plchltotfbfiles 
     489         ENDIF 
     490         IF (ln_pchltot) THEN 
     491            jtype = jtype + 1 
     492            cobstypesprof(jtype) = 'pchltot' 
     493            clproffiles(jtype,:) = cn_pchltotfbfiles 
     494         ENDIF 
     495         IF (ln_pno3) THEN 
     496            jtype = jtype + 1 
     497            cobstypesprof(jtype) = 'pno3' 
     498            clproffiles(jtype,:) = cn_pno3fbfiles 
     499         ENDIF 
     500         IF (ln_psi4) THEN 
     501            jtype = jtype + 1 
     502            cobstypesprof(jtype) = 'psi4' 
     503            clproffiles(jtype,:) = cn_psi4fbfiles 
     504         ENDIF 
     505         IF (ln_ppo4) THEN 
     506            jtype = jtype + 1 
     507            cobstypesprof(jtype) = 'ppo4' 
     508            clproffiles(jtype,:) = cn_ppo4fbfiles 
     509         ENDIF 
     510         IF (ln_pdic) THEN 
     511            jtype = jtype + 1 
     512            cobstypesprof(jtype) = 'pdic' 
     513            clproffiles(jtype,:) = cn_pdicfbfiles 
     514         ENDIF 
     515         IF (ln_palk) THEN 
     516            jtype = jtype + 1 
     517            cobstypesprof(jtype) = 'palk' 
     518            clproffiles(jtype,:) = cn_palkfbfiles 
     519         ENDIF 
     520         IF (ln_pph) THEN 
     521            jtype = jtype + 1 
     522            cobstypesprof(jtype) = 'pph' 
     523            clproffiles(jtype,:) = cn_pphfbfiles 
     524         ENDIF 
     525         IF (ln_po2) THEN 
     526            jtype = jtype + 1 
     527            cobstypesprof(jtype) = 'po2' 
     528            clproffiles(jtype,:) = cn_po2fbfiles 
     529         ENDIF 
     530 
     531         CALL obs_settypefiles( nproftypes, jpmaxnfiles, ifilesprof, cobstypesprof, clproffiles ) 
     532 
     533      ENDIF 
     534 
     535      IF(lwp) WRITE(numout,*)'          Number of surface obs types: ',nsurftypes 
     536      IF ( nsurftypes > 0 ) THEN 
     537 
     538         ALLOCATE( cobstypessurf(nsurftypes) ) 
     539         ALLOCATE( ifilessurf(nsurftypes) ) 
     540         ALLOCATE( clsurffiles(nsurftypes, jpmaxnfiles) ) 
     541         ALLOCATE(n2dintsurf(nsurftypes)) 
     542         ALLOCATE(ravglamscl(nsurftypes)) 
     543         ALLOCATE(ravgphiscl(nsurftypes)) 
     544         ALLOCATE(lfpindegs(nsurftypes)) 
     545         ALLOCATE(llnightav(nsurftypes)) 
     546 
     547         jtype = 0 
     548         IF (ln_sla) THEN 
     549            jtype = jtype + 1 
     550            cobstypessurf(jtype) = 'sla' 
     551            clsurffiles(jtype,:) = cn_slafbfiles 
     552         ENDIF 
     553         IF (ln_sst) THEN 
     554            jtype = jtype + 1 
     555            cobstypessurf(jtype) = 'sst' 
     556            clsurffiles(jtype,:) = cn_sstfbfiles 
     557         ENDIF 
     558         IF (ln_sic) THEN 
     559            jtype = jtype + 1 
     560            cobstypessurf(jtype) = 'sic' 
     561            clsurffiles(jtype,:) = cn_sicfbfiles 
     562         ENDIF 
     563         IF (ln_sss) THEN 
     564            jtype = jtype + 1 
     565            cobstypessurf(jtype) = 'sss' 
     566            clsurffiles(jtype,:) = cn_sssfbfiles 
     567         ENDIF 
     568         IF (ln_slchltot) THEN 
     569            jtype = jtype + 1 
     570            cobstypessurf(jtype) = 'slchltot' 
     571            clsurffiles(jtype,:) = cn_slchltotfbfiles 
     572         ENDIF 
     573         IF (ln_slchldia) THEN 
     574            jtype = jtype + 1 
     575            cobstypessurf(jtype) = 'slchldia' 
     576            clsurffiles(jtype,:) = cn_slchldiafbfiles 
     577         ENDIF 
     578         IF (ln_slchlnon) THEN 
     579            jtype = jtype + 1 
     580            cobstypessurf(jtype) = 'slchlnon' 
     581            clsurffiles(jtype,:) = cn_slchlnonfbfiles 
     582         ENDIF 
     583         IF (ln_slchldin) THEN 
     584            jtype = jtype + 1 
     585            cobstypessurf(jtype) = 'slchldin' 
     586            clsurffiles(jtype,:) = cn_slchldinfbfiles 
     587         ENDIF 
     588         IF (ln_slchlmic) THEN 
     589            jtype = jtype + 1 
     590            cobstypessurf(jtype) = 'slchlmic' 
     591            clsurffiles(jtype,:) = cn_slchlmicfbfiles 
     592         ENDIF 
     593         IF (ln_slchlnan) THEN 
     594            jtype = jtype + 1 
     595            cobstypessurf(jtype) = 'slchlnan' 
     596            clsurffiles(jtype,:) = cn_slchlnanfbfiles 
     597         ENDIF 
     598         IF (ln_slchlpic) THEN 
     599            jtype = jtype + 1 
     600            cobstypessurf(jtype) = 'slchlpic' 
     601            clsurffiles(jtype,:) = cn_slchlpicfbfiles 
     602         ENDIF 
     603         IF (ln_schltot) THEN 
     604            jtype = jtype + 1 
     605            cobstypessurf(jtype) = 'schltot' 
     606            clsurffiles(jtype,:) = cn_schltotfbfiles 
     607         ENDIF 
     608         IF (ln_slphytot) THEN 
     609            jtype = jtype + 1 
     610            cobstypessurf(jtype) = 'slphytot' 
     611            clsurffiles(jtype,:) = cn_slphytotfbfiles 
     612         ENDIF 
     613         IF (ln_slphydia) THEN 
     614            jtype = jtype + 1 
     615            cobstypessurf(jtype) = 'slphydia' 
     616            clsurffiles(jtype,:) = cn_slphydiafbfiles 
     617         ENDIF 
     618         IF (ln_slphynon) THEN 
     619            jtype = jtype + 1 
     620            cobstypessurf(jtype) = 'slphynon' 
     621            clsurffiles(jtype,:) = cn_slphynonfbfiles 
     622         ENDIF 
     623         IF (ln_sspm) THEN 
     624            jtype = jtype + 1 
     625            cobstypessurf(jtype) = 'sspm' 
     626            clsurffiles(jtype,:) = cn_sspmfbfiles 
     627         ENDIF 
     628         IF (ln_skd490) THEN 
     629            jtype = jtype + 1 
     630            cobstypessurf(jtype) = 'skd490' 
     631            clsurffiles(jtype,:) = cn_skd490fbfiles 
     632         ENDIF 
     633         IF (ln_sfco2) THEN 
     634            jtype = jtype + 1 
     635            cobstypessurf(jtype) = 'sfco2' 
     636            clsurffiles(jtype,:) = cn_sfco2fbfiles 
     637         ENDIF 
     638         IF (ln_spco2) THEN 
     639            jtype = jtype + 1 
     640            cobstypessurf(jtype) = 'spco2' 
     641            clsurffiles(jtype,:) = cn_spco2fbfiles 
     642         ENDIF 
     643 
     644         CALL obs_settypefiles( nsurftypes, jpmaxnfiles, ifilessurf, cobstypessurf, clsurffiles ) 
     645 
     646         DO jtype = 1, nsurftypes 
     647 
     648            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     649               IF ( nn_2dint_sla == -1 ) THEN 
     650                  n2dint_type  = nn_2dint_default 
    371651               ELSE 
    372                   WRITE(numout,'(1X,2A)') '             Feedback input observation file name       profbfiles = ', & 
    373                      TRIM(profbfiles(ji)) 
     652                  n2dint_type  = nn_2dint_sla 
    374653               ENDIF 
    375                WRITE(numout,'(1X,2A)') '       Enact feedback input time setting switch    ln_profb_enatim = ', ln_profb_enatim(ji) 
    376             END DO 
    377          ENDIF 
    378          IF (ln_sladt) THEN 
    379             DO ji = 1, jnumslaact 
    380                WRITE(numout,'(1X,2A)') '             Active SLA input observation file name    slafilesact = ', & 
    381                   TRIM(slafilesact(ji)) 
    382             END DO 
    383             DO ji = 1, jnumslapas 
    384                WRITE(numout,'(1X,2A)') '             Passive SLA input observation file name   slafilespas = ', & 
    385                   TRIM(slafilespas(ji)) 
    386             END DO 
    387          ENDIF 
    388          IF (ln_slafb) THEN 
    389             DO ji = 1, jnumslafb 
    390                WRITE(numout,'(1X,2A)') '             Feedback SLA input observation file name   slafbfiles = ', & 
    391                   TRIM(slafbfiles(ji)) 
    392             END DO 
    393          ENDIF 
    394          IF (ln_ghrsst) THEN 
    395             DO ji = 1, jnumsst 
    396                WRITE(numout,'(1X,2A)') '             GHRSST input observation file name           sstfiles = ', & 
    397                   TRIM(sstfiles(ji)) 
    398             END DO 
    399          ENDIF 
    400          IF (ln_sstfb) THEN 
    401             DO ji = 1, jnumsstfb 
    402                WRITE(numout,'(1X,2A)') '             Feedback SST input observation file name   sstfbfiles = ', & 
    403                   TRIM(sstfbfiles(ji)) 
    404             END DO 
    405          ENDIF 
    406          IF (ln_seaice) THEN 
    407             DO ji = 1, jnumseaice 
    408                WRITE(numout,'(1X,2A)') '             Sea Ice input observation file name       seaicefiles = ', & 
    409                   TRIM(seaicefiles(ji)) 
    410             END DO 
    411          ENDIF 
    412          IF (ln_velavcur) THEN 
    413             DO ji = 1, jnumvelavcur 
    414                WRITE(numout,'(1X,2A)') '             Vel. cur. daily av. input file name     velavcurfiles = ', & 
    415                   TRIM(velavcurfiles(ji)) 
    416             END DO 
    417          ENDIF 
    418          IF (ln_velhrcur) THEN 
    419             DO ji = 1, jnumvelhrcur 
    420                WRITE(numout,'(1X,2A)') '             Vel. cur. high freq. input file name    velhvcurfiles = ', & 
    421                   TRIM(velhrcurfiles(ji)) 
    422             END DO 
    423          ENDIF 
    424          IF (ln_velavadcp) THEN 
    425             DO ji = 1, jnumvelavadcp 
    426                WRITE(numout,'(1X,2A)') '             Vel. ADCP daily av. input file name    velavadcpfiles = ', & 
    427                   TRIM(velavadcpfiles(ji)) 
    428             END DO 
    429          ENDIF 
    430          IF (ln_velhradcp) THEN 
    431             DO ji = 1, jnumvelhradcp 
    432                WRITE(numout,'(1X,2A)') '             Vel. ADCP high freq. input file name   velhvadcpfiles = ', & 
    433                   TRIM(velhradcpfiles(ji)) 
    434             END DO 
    435          ENDIF 
    436          IF (ln_velfb) THEN 
    437             DO ji = 1, jnumvelfb 
    438                IF (ln_velfb_av(ji)) THEN 
    439                   WRITE(numout,'(1X,2A)') '             Vel. feedback daily av. input file name    velfbfiles = ', & 
    440                      TRIM(velfbfiles(ji)) 
     654               ztype_avglamscl = rn_sla_avglamscl 
     655               ztype_avgphiscl = rn_sla_avgphiscl 
     656               ltype_fp_indegs = ln_sla_fp_indegs 
     657               ltype_night     = .FALSE. 
     658            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 
     659               IF ( nn_2dint_sst == -1 ) THEN 
     660                  n2dint_type  = nn_2dint_default 
    441661               ELSE 
    442                   WRITE(numout,'(1X,2A)') '             Vel. feedback input observation file name  velfbfiles = ', & 
    443                      TRIM(velfbfiles(ji)) 
     662                  n2dint_type  = nn_2dint_sst 
    444663               ENDIF 
    445             END DO 
    446          ENDIF 
    447          WRITE(numout,*) '             Initial date in window YYYYMMDD.HHMMSS        dobsini = ', dobsini 
    448          WRITE(numout,*) '             Final date in window YYYYMMDD.HHMMSS          dobsend = ', dobsend 
    449          WRITE(numout,*) '             Type of vertical interpolation method          n1dint = ', n1dint 
    450          WRITE(numout,*) '             Type of horizontal interpolation method        n2dint = ', n2dint 
    451          WRITE(numout,*) '             Rejection of observations near land swithch    ln_nea = ', ln_nea 
    452          WRITE(numout,*) '             MSSH correction scheme                         nmsshc = ', nmsshc 
    453          WRITE(numout,*) '             MDT  correction                               mdtcorr = ', mdtcorr 
    454          WRITE(numout,*) '             MDT cutoff for computed correction          mdtcutoff = ', mdtcutoff 
    455          WRITE(numout,*) '             Logical switch for alt bias                ln_altbias = ', ln_altbias 
    456          WRITE(numout,*) '             Logical switch for ignoring missing files   ln_ignmis = ', ln_ignmis 
    457          WRITE(numout,*) '             ENACT daily average types                             = ',endailyavtypes 
     664               ztype_avglamscl = rn_sst_avglamscl 
     665               ztype_avgphiscl = rn_sst_avgphiscl 
     666               ltype_fp_indegs = ln_sst_fp_indegs 
     667               ltype_night     = ln_sstnight 
     668            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 
     669               IF ( nn_2dint_sic == -1 ) THEN 
     670                  n2dint_type  = nn_2dint_default 
     671               ELSE 
     672                  n2dint_type  = nn_2dint_sic 
     673               ENDIF 
     674               ztype_avglamscl = rn_sic_avglamscl 
     675               ztype_avgphiscl = rn_sic_avgphiscl 
     676               ltype_fp_indegs = ln_sic_fp_indegs 
     677               ltype_night     = .FALSE. 
     678            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 
     679               IF ( nn_2dint_sss == -1 ) THEN 
     680                  n2dint_type  = nn_2dint_default 
     681               ELSE 
     682                  n2dint_type  = nn_2dint_sss 
     683               ENDIF 
     684               ztype_avglamscl = rn_sss_avglamscl 
     685               ztype_avgphiscl = rn_sss_avgphiscl 
     686               ltype_fp_indegs = ln_sss_fp_indegs 
     687               ltype_night     = .FALSE. 
     688            ELSE 
     689               n2dint_type     = nn_2dint_default 
     690               ztype_avglamscl = rn_default_avglamscl 
     691               ztype_avgphiscl = rn_default_avgphiscl 
     692               ltype_fp_indegs = ln_default_fp_indegs 
     693               ltype_night     = .FALSE. 
     694            ENDIF 
     695             
     696            CALL obs_setinterpopts( nsurftypes, jtype, TRIM(cobstypessurf(jtype)), & 
     697               &                    nn_2dint_default, n2dint_type,                 & 
     698               &                    ztype_avglamscl, ztype_avgphiscl,              & 
     699               &                    ltype_fp_indegs, ltype_night,                  & 
     700               &                    n2dintsurf, ravglamscl, ravgphiscl,            & 
     701               &                    lfpindegs, llnightav ) 
     702 
     703         END DO 
    458704 
    459705      ENDIF 
    460        
     706 
     707      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     708 
     709 
     710      !----------------------------------------------------------------------- 
     711      ! Obs operator parameter checking and initialisations 
     712      !----------------------------------------------------------------------- 
     713 
    461714      IF ( ln_vel3d .AND. ( .NOT. ln_grid_global ) ) THEN 
    462715         CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) 
    … …  
    464717      ENDIF 
    465718 
    466       CALL obs_typ_init 
    467        
    468       CALL mppmap_init 
    469        
    470       ! Parameter control 
    471 #if defined key_diaobs 
    472       IF ( ( .NOT. ln_t3d ).AND.( .NOT. ln_s3d ).AND.( .NOT. ln_sla ).AND. & 
    473          & ( .NOT. ln_vel3d ).AND.                                         & 
    474          & ( .NOT. ln_ssh ).AND.( .NOT. ln_sst ).AND.( .NOT. ln_sss ).AND. & 
    475          & ( .NOT. ln_seaice ).AND.( .NOT. ln_vel3d ) ) THEN 
    476          IF(lwp) WRITE(numout,cform_war) 
    477          IF(lwp) WRITE(numout,*) ' key_diaobs is activated but logical flags', & 
    478             &                    ' ln_t3d, ln_s3d, ln_sla, ln_ssh, ln_sst, ln_sss, ln_seaice, ln_vel3d are all set to .FALSE.' 
    479          nwarn = nwarn + 1 
    480       ENDIF 
    481 #endif 
    482  
    483       CALL obs_grid_setup( ) 
    484       IF ( ( n1dint < 0 ).OR.( n1dint > 1 ) ) THEN 
     719      IF ( ( nn_1dint < 0 ) .OR. ( nn_1dint > 1 ) ) THEN 
    485720         CALL ctl_stop(' Choice of vertical (1D) interpolation method', & 
    486721            &                    ' is not available') 
    487722      ENDIF 
    488       IF ( ( n2dint < 0 ).OR.( n2dint > 4 ) ) THEN 
    489          CALL ctl_stop(' Choice of horizontal (2D) interpolation method', & 
     723 
     724      IF ( ( nn_2dint_default < 0 ) .OR. ( nn_2dint_default > 6 ) ) THEN 
     725         CALL ctl_stop(' Choice of default horizontal (2D) interpolation method', & 
    490726            &                    ' is not available') 
    491727      ENDIF 
     728 
     729      CALL obs_typ_init 
     730 
     731      CALL mppmap_init 
     732 
     733      CALL obs_grid_setup( ) 
    492734 
    493735      !----------------------------------------------------------------------- 
    494736      ! Depending on switches read the various observation types 
    495737      !----------------------------------------------------------------------- 
    496       !  - Temperature/salinity profiles 
    497  
    498       IF ( ln_t3d .OR. ln_s3d ) THEN 
    499  
    500          ! Set the number of variables for profiles to 2 (T and S) 
    501          nprofvars = 2 
    502          ! Set the number of extra variables for profiles to 1 (insitu temp). 
    503          nprofextr = 1 
    504  
    505          ! Count how may insitu data sets we have and allocate data. 
    506          jprofset = 0 
    507          IF ( ln_ena ) jprofset = jprofset + 1 
    508          IF ( ln_cor ) jprofset = jprofset + 1 
    509          IF ( ln_profb ) jprofset = jprofset + jnumprofb 
    510          nprofsets = jprofset 
    511          IF ( nprofsets > 0 ) THEN 
    512             ALLOCATE(ld_enact(nprofsets)) 
    513             ALLOCATE(profdata(nprofsets)) 
    514             ALLOCATE(prodatqc(nprofsets)) 
    515          ENDIF 
    516  
    517          jprofset = 0 
    518            
    519          ! ENACT insitu data 
    520  
    521          IF ( ln_ena ) THEN 
    522  
    523             jprofset = jprofset + 1 
     738 
     739      IF ( nproftypes > 0 ) THEN 
     740 
     741         ALLOCATE(profdata(nproftypes)) 
     742         ALLOCATE(profdataqc(nproftypes)) 
     743         ALLOCATE(nvarsprof(nproftypes)) 
     744         ALLOCATE(nextrprof(nproftypes)) 
     745 
     746         DO jtype = 1, nproftypes 
    524747             
    525             ld_enact(jprofset) = .TRUE. 
    526  
    527             CALL obs_rea_pro_dri( 1, profdata(jprofset),          & 
    528                &                  jnumenact, enactfiles(1:jnumenact), & 
    529                &                  nprofvars, nprofextr,        & 
    530                &                  nitend-nit000+2,             & 
    531                &                  dobsini, dobsend, ln_t3d, ln_s3d, & 
    532                &                  ln_ignmis, ln_s_at_t, .TRUE., .FALSE., & 
    533                &                  kdailyavtypes = endailyavtypes ) 
    534  
    535             DO jvar = 1, 2 
    536  
    537                CALL obs_prof_staend( profdata(jprofset), jvar ) 
    538  
     748            ltype_clim = .FALSE.  
     749             
     750            IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 
     751               nvarsprof(jtype) = 2 
     752               nextrprof(jtype) = 1 
     753               IF ( ln_output_clim ) ltype_clim = .TRUE.               
     754               ALLOCATE(llvar(nvarsprof(jtype))) 
     755               ALLOCATE(clvars(nvarsprof(jtype))) 
     756               CALL wrk_alloc( jpi, jpj,      nvarsprof(jtype), zglam ) 
     757               CALL wrk_alloc( jpi, jpj,      nvarsprof(jtype), zgphi ) 
     758               CALL wrk_alloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 
     759               llvar(1)       = ln_t3d 
     760               llvar(2)       = ln_s3d 
     761               clvars(1)      = 'POTM' 
     762               clvars(2)      = 'PSAL' 
     763               zglam(:,:,1)   = glamt(:,:) 
     764               zglam(:,:,2)   = glamt(:,:) 
     765               zgphi(:,:,1)   = gphit(:,:) 
     766               zgphi(:,:,2)   = gphit(:,:) 
     767               zmask(:,:,:,1) = tmask(:,:,:) 
     768               zmask(:,:,:,2) = tmask(:,:,:) 
     769            ELSE IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN 
     770               nvarsprof(jtype) = 2 
     771               nextrprof(jtype) = 2 
     772               ALLOCATE(llvar(nvarsprof(jtype))) 
     773               ALLOCATE(clvars(nvarsprof(jtype))) 
     774               CALL wrk_alloc( jpi, jpj,      nvarsprof(jtype), zglam ) 
     775               CALL wrk_alloc( jpi, jpj,      nvarsprof(jtype), zgphi ) 
     776               CALL wrk_alloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 
     777               llvar(1)       = ln_vel3d 
     778               llvar(2)       = ln_vel3d 
     779               clvars(1)      = 'UVEL' 
     780               clvars(2)      = 'VVEL' 
     781               zglam(:,:,1)   = glamu(:,:) 
     782               zglam(:,:,2)   = glamv(:,:) 
     783               zgphi(:,:,1)   = gphiu(:,:) 
     784               zgphi(:,:,2)   = gphiv(:,:) 
     785               zmask(:,:,:,1) = umask(:,:,:) 
     786               zmask(:,:,:,2) = vmask(:,:,:) 
     787            ELSE 
     788               nvarsprof(jtype) = 1 
     789               nextrprof(jtype) = 0 
     790               ALLOCATE(llvar(nvarsprof(jtype))) 
     791               ALLOCATE(clvars(nvarsprof(jtype))) 
     792               CALL wrk_alloc( jpi, jpj,      nvarsprof(jtype), zglam ) 
     793               CALL wrk_alloc( jpi, jpj,      nvarsprof(jtype), zgphi ) 
     794               CALL wrk_alloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 
     795               llvar(1)       = .TRUE. 
     796               zglam(:,:,1)   = glamt(:,:) 
     797               zgphi(:,:,1)   = gphit(:,:) 
     798               zmask(:,:,:,1) = tmask(:,:,:) 
     799               IF ( TRIM(cobstypesprof(jtype)) == 'plchltot' )  THEN 
     800                  clvars(1) = 'PLCHLTOT' 
     801               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'pchltot' )  THEN 
     802                  clvars(1) = 'PCHLTOT' 
     803               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'pno3' )  THEN 
     804                  clvars(1) = 'PNO3' 
     805               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'psi4' )  THEN 
     806                  clvars(1) = 'PSI4' 
     807               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'ppo4' )  THEN 
     808                  clvars(1) = 'PPO4' 
     809               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'pdic' )  THEN 
     810                  clvars(1) = 'PDIC' 
     811               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'palk' )  THEN 
     812                  clvars(1) = 'PALK' 
     813               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'pph' )  THEN 
     814                  clvars(1) = 'PPH' 
     815               ELSE IF ( TRIM(cobstypesprof(jtype)) == 'po2' )  THEN 
     816                  clvars(1) = 'PO2' 
     817               ENDIF 
     818            ENDIF 
     819 
     820            !Read in profile or profile obs types 
     821            CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype),       & 
     822               &               clproffiles(jtype,1:ifilesprof(jtype)), & 
     823               &               nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 
     824               &               rn_dobsini, rn_dobsend, llvar, & 
     825               &               ln_ignmis, ln_s_at_t, .FALSE., ltype_clim, clvars, & 
     826               &               kdailyavtypes = nn_profdavtypes ) 
     827 
     828            DO jvar = 1, nvarsprof(jtype) 
     829               CALL obs_prof_staend( profdata(jtype), jvar ) 
    539830            END DO 
    540831 
    541             CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset),   & 
    542                &              ln_t3d, ln_s3d, ln_nea, & 
    543                &              kdailyavtypes=endailyavtypes ) 
     832            CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 
     833               &               llvar, & 
     834               &               jpi, jpj, jpk, & 
     835               &               zmask, zglam, zgphi,  & 
     836               &               ln_nea, ln_bound_reject, & 
     837               &               kdailyavtypes = nn_profdavtypes ) 
    544838             
    545          ENDIF 
    546  
    547          ! Coriolis insitu data 
    548  
    549          IF ( ln_cor ) THEN 
    550             
    551             jprofset = jprofset + 1 
    552  
    553             ld_enact(jprofset) = .FALSE. 
    554  
    555             CALL obs_rea_pro_dri( 2, profdata(jprofset),          & 
    556                &                  jnumcorio, coriofiles(1:jnumcorio), & 
    557                &                  nprofvars, nprofextr,        & 
    558                &                  nitend-nit000+2,             & 
    559                &                  dobsini, dobsend, ln_t3d, ln_s3d, & 
    560                &                  ln_ignmis, ln_s_at_t, .FALSE., .FALSE. ) 
    561  
    562             DO jvar = 1, 2 
    563  
    564                CALL obs_prof_staend( profdata(jprofset), jvar ) 
    565  
    566             END DO 
    567  
    568             CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset),   & 
    569                  &            ln_t3d, ln_s3d, ln_nea ) 
     839            DEALLOCATE( llvar, clvars ) 
     840            CALL wrk_dealloc( jpi, jpj,      nvarsprof(jtype), zglam ) 
     841            CALL wrk_dealloc( jpi, jpj,      nvarsprof(jtype), zgphi ) 
     842            CALL wrk_dealloc( jpi, jpj, jpk, nvarsprof(jtype), zmask ) 
     843 
     844         END DO 
     845 
     846         DEALLOCATE( ifilesprof, clproffiles ) 
     847 
     848      ENDIF 
     849 
     850      IF ( nsurftypes > 0 ) THEN 
     851 
     852         ALLOCATE(surfdata(nsurftypes)) 
     853         ALLOCATE(surfdataqc(nsurftypes)) 
     854         ALLOCATE(nvarssurf(nsurftypes)) 
     855         ALLOCATE(nextrsurf(nsurftypes)) 
     856 
     857         DO jtype = 1, nsurftypes 
     858 
     859            ltype_clim = .FALSE. 
     860            IF ( ln_output_clim .AND. & 
     861               & ( ( TRIM(cobstypessurf(jtype)) == 'sst' ) .OR. & 
     862               &   ( TRIM(cobstypessurf(jtype)) == 'sss' ) ) ) & 
     863               & ltype_clim = .TRUE. 
     864 
     865            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     866               nvarssurf(jtype) = 1 
     867               nextrsurf(jtype) = 2 
     868            ELSE 
     869               nvarssurf(jtype) = 1 
     870               nextrsurf(jtype) = 0 
     871            ENDIF 
    570872             
    571          ENDIF 
    572   
    573          ! Feedback insitu data 
    574  
    575          IF ( ln_profb ) THEN 
    576             
    577             DO jset = 1, jnumprofb 
    578                 
    579                jprofset = jprofset + 1 
    580                ld_enact (jprofset) = ln_profb_ena(jset) 
    581  
    582                CALL obs_rea_pro_dri( 0, profdata(jprofset),          & 
    583                   &                  1, profbfiles(jset:jset), & 
    584                   &                  nprofvars, nprofextr,        & 
    585                   &                  nitend-nit000+2,             & 
    586                   &                  dobsini, dobsend, ln_t3d, ln_s3d, & 
    587                   &                  ln_ignmis, ln_s_at_t, & 
    588                   &                  ld_enact(jprofset).AND.& 
    589                   &                  ln_profb_enatim(jset), & 
    590                   &                  .FALSE., kdailyavtypes = endailyavtypes ) 
    591                 
    592                DO jvar = 1, 2 
    593                    
    594                   CALL obs_prof_staend( profdata(jprofset), jvar ) 
    595                    
     873            ALLOCATE( clvars( nvarssurf(jtype) ) ) 
     874 
     875            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     876               clvars(1) = 'SLA' 
     877            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) THEN 
     878               clvars(1) = 'SST' 
     879            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sic' ) THEN 
     880               clvars(1) = 'ICECONC' 
     881            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sss' ) THEN 
     882               clvars(1) = 'SSS' 
     883            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchltot' ) THEN 
     884               clvars(1) = 'SLCHLTOT' 
     885            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchldia' ) THEN 
     886               clvars(1) = 'SLCHLDIA' 
     887            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchlnon' ) THEN 
     888               clvars(1) = 'SLCHLNON' 
     889            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchldin' ) THEN 
     890               clvars(1) = 'SLCHLDIN' 
     891            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchlmic' ) THEN 
     892               clvars(1) = 'SLCHLMIC' 
     893            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchlnan' ) THEN 
     894               clvars(1) = 'SLCHLNAN' 
     895            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slchlpic' ) THEN 
     896               clvars(1) = 'SLCHLPIC' 
     897            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'schltot' ) THEN 
     898               clvars(1) = 'SCHLTOT' 
     899            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slphytot' ) THEN 
     900               clvars(1) = 'SLPHYTOT' 
     901            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slphydia' ) THEN 
     902               clvars(1) = 'SLPHYDIA' 
     903            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'slphynon' ) THEN 
     904               clvars(1) = 'SLPHYNON' 
     905            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sspm' ) THEN 
     906               clvars(1) = 'SSPM' 
     907            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'skd490' ) THEN 
     908               clvars(1) = 'SKD490' 
     909            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'sfco2' ) THEN 
     910               clvars(1) = 'SFCO2' 
     911            ELSE IF ( TRIM(cobstypessurf(jtype)) == 'spco2' ) THEN 
     912               clvars(1) = 'SPCO2' 
     913            ENDIF 
     914 
     915            !Read in surface obs types 
     916            CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 
     917               &               clsurffiles(jtype,1:ifilessurf(jtype)), & 
     918               &               nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 
     919               &               rn_dobsini, rn_dobsend, MeanPeriodHours, ln_ignmis, .FALSE., & 
     920               &               llnightav(jtype), ltype_clim, ln_time_mean_sla_bkg, clvars ) 
     921 
     922            CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea, ln_bound_reject ) 
     923 
     924            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     925               CALL obs_rea_mdt( surfdataqc(jtype), n2dintsurf(jtype) ) 
     926               IF ( ln_altbias ) & 
     927                  & CALL obs_rea_altbias ( surfdataqc(jtype), n2dintsurf(jtype), cn_altbiasfile ) 
     928            ENDIF 
     929 
     930            IF ( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN 
     931               jnumsstbias = 0 
     932               DO jfile = 1, jpmaxnfiles 
     933                  IF ( TRIM(cn_sstbiasfiles(jfile)) /= '' ) & 
     934                     &  jnumsstbias = jnumsstbias + 1 
    596935               END DO 
    597                 
    598                IF ( ld_enact(jprofset) ) THEN 
    599                   CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset),   & 
    600                      &              ln_t3d, ln_s3d, ln_nea, & 
    601                      &              kdailyavtypes = endailyavtypes ) 
    602                ELSE 
    603                   CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset),   & 
    604                      &              ln_t3d, ln_s3d, ln_nea ) 
     936               IF ( jnumsstbias == 0 ) THEN 
     937                  CALL ctl_stop("ln_sstbias set but no bias files to read in")     
    605938               ENDIF 
    606                 
    607             END DO 
    608  
    609          ENDIF 
     939 
     940               CALL obs_app_sstbias( surfdataqc(jtype), n2dintsurf(jtype), &  
     941                  &                  jnumsstbias, cn_sstbiasfiles(1:jnumsstbias) )  
     942 
     943            ENDIF 
     944             
     945            DEALLOCATE( clvars ) 
     946 
     947         END DO 
     948 
     949         DEALLOCATE( ifilessurf, clsurffiles ) 
    610950 
    611951      ENDIF 
    612952 
    613       !  - Sea level anomalies 
    614       IF ( ln_sla ) THEN 
    615         ! Set the number of variables for sla to 1 
    616          nslavars = 1 
    617  
    618          ! Set the number of extra variables for sla to 2 
    619          nslaextr = 2 
    620           
    621          ! Set the number of sla data sets to 2 
    622          nslasets = 0 
    623          IF ( ln_sladt ) THEN 
    624             nslasets = nslasets + 2 
    625          ENDIF 
    626          IF ( ln_slafb ) THEN 
    627             nslasets = nslasets + jnumslafb 
    628          ENDIF 
    629           
    630          ALLOCATE(sladata(nslasets)) 
    631          ALLOCATE(sladatqc(nslasets)) 
    632          sladata(:)%nsurf=0 
    633          sladatqc(:)%nsurf=0 
    634  
    635          nslasets = 0 
    636  
    637          ! AVISO SLA data 
    638  
    639          IF ( ln_sladt ) THEN 
    640  
    641             ! Active SLA observations 
    642              
    643             nslasets = nslasets + 1 
    644              
    645             CALL obs_rea_sla( 1, sladata(nslasets), jnumslaact, & 
    646                &              slafilesact(1:jnumslaact), & 
    647                &              nslavars, nslaextr, nitend-nit000+2, & 
    648                &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
    649             CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), & 
    650                &              ln_sla, ln_nea ) 
    651              
    652             ! Passive SLA observations 
    653              
    654             nslasets = nslasets + 1 
    655              
    656             CALL obs_rea_sla( 1, sladata(nslasets), jnumslapas, & 
    657                &              slafilespas(1:jnumslapas), & 
    658                &              nslavars, nslaextr, nitend-nit000+2, & 
    659                &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
    660              
    661             CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), & 
    662                &              ln_sla, ln_nea ) 
    663  
    664          ENDIF 
    665           
    666          ! Feedback SLA data 
    667  
    668          IF ( ln_slafb ) THEN 
    669  
    670             DO jset = 1, jnumslafb 
    671              
    672                nslasets = nslasets + 1 
    673              
    674                CALL obs_rea_sla( 0, sladata(nslasets), 1, & 
    675                   &              slafbfiles(jset:jset), & 
    676                   &              nslavars, nslaextr, nitend-nit000+2, & 
    677                   &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
    678                CALL obs_pre_sla( sladata(nslasets), sladatqc(nslasets), & 
    679                   &              ln_sla, ln_nea ) 
    680  
    681             END DO                
    682  
    683          ENDIF 
    684           
    685          CALL obs_rea_mdt( nslasets, sladatqc, n2dint ) 
    686              
    687          ! read in altimeter bias 
    688           
    689          IF ( ln_altbias ) THEN      
    690             CALL obs_rea_altbias ( nslasets, sladatqc, n2dint, bias_file ) 
    691          ENDIF 
    692       
    693       ENDIF 
    694  
    695       !  - Sea surface height 
    696       IF ( ln_ssh ) THEN 
    697          IF(lwp) WRITE(numout,*) ' SSH currently not available' 
    698       ENDIF 
    699  
    700       !  - Sea surface temperature 
    701       IF ( ln_sst ) THEN 
    702  
    703          ! Set the number of variables for sst to 1 
    704          nsstvars = 1 
    705  
    706          ! Set the number of extra variables for sst to 0 
    707          nsstextr = 0 
    708  
    709          nsstsets = 0 
    710  
    711          IF (ln_reysst) nsstsets = nsstsets + 1 
    712          IF (ln_ghrsst) nsstsets = nsstsets + 1 
    713          IF ( ln_sstfb ) THEN 
    714             nsstsets = nsstsets + jnumsstfb 
    715          ENDIF 
    716  
    717          ALLOCATE(sstdata(nsstsets)) 
    718          ALLOCATE(sstdatqc(nsstsets)) 
    719          ALLOCATE(ld_sstnight(nsstsets)) 
    720          sstdata(:)%nsurf=0 
    721          sstdatqc(:)%nsurf=0     
    722          ld_sstnight(:)=.false. 
    723  
    724          nsstsets = 0 
    725  
    726          IF (ln_reysst) THEN 
    727  
    728             nsstsets = nsstsets + 1 
    729  
    730             ld_sstnight(nsstsets) = ln_sstnight 
    731  
    732             CALL obs_rea_sst_rey( reysstname, reysstfmt, sstdata(nsstsets), & 
    733                &                  nsstvars, nsstextr, & 
    734                &                  nitend-nit000+2, dobsini, dobsend ) 
    735             CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, & 
    736                &              ln_nea ) 
    737  
    738         ENDIF 
    739          
    740         IF (ln_ghrsst) THEN 
    741          
    742             nsstsets = nsstsets + 1 
    743  
    744             ld_sstnight(nsstsets) = ln_sstnight 
    745            
    746             CALL obs_rea_sst( 1, sstdata(nsstsets), jnumsst, & 
    747                &              sstfiles(1:jnumsst), & 
    748                &              nsstvars, nsstextr, nitend-nit000+2, & 
    749                &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
    750             CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, & 
    751                &              ln_nea ) 
    752  
    753         ENDIF 
    754                 
    755          ! Feedback SST data 
    756  
    757          IF ( ln_sstfb ) THEN 
    758  
    759             DO jset = 1, jnumsstfb 
    760              
    761                nsstsets = nsstsets + 1 
    762  
    763                ld_sstnight(nsstsets) = ln_sstnight 
    764              
    765                CALL obs_rea_sst( 0, sstdata(nsstsets), 1, & 
    766                   &              sstfbfiles(jset:jset), & 
    767                   &              nsstvars, nsstextr, nitend-nit000+2, & 
    768                   &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
    769                CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), & 
    770                   &              ln_sst, ln_nea ) 
    771  
    772             END DO                
    773  
    774          ENDIF 
    775  
    776       ENDIF 
    777  
    778       !  - Sea surface salinity 
    779       IF ( ln_sss ) THEN 
    780          IF(lwp) WRITE(numout,*) ' SSS currently not available' 
    781       ENDIF 
    782  
    783       !  - Sea Ice Concentration 
    784        
    785       IF ( ln_seaice ) THEN 
    786  
    787          ! Set the number of variables for seaice to 1 
    788          nseaicevars = 1 
    789  
    790          ! Set the number of extra variables for seaice to 0 
    791          nseaiceextr = 0 
    792           
    793          ! Set the number of data sets to 1 
    794          nseaicesets = 1 
    795  
    796          ALLOCATE(seaicedata(nseaicesets)) 
    797          ALLOCATE(seaicedatqc(nseaicesets)) 
    798          seaicedata(:)%nsurf=0 
    799          seaicedatqc(:)%nsurf=0 
    800  
    801          CALL obs_rea_seaice( 1, seaicedata(nseaicesets), jnumseaice, & 
    802             &                 seaicefiles(1:jnumseaice), & 
    803             &                 nseaicevars, nseaiceextr, nitend-nit000+2, & 
    804             &                 dobsini, dobsend, ln_ignmis, .FALSE. ) 
    805  
    806          CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), & 
    807             &                 ln_seaice, ln_nea ) 
    808   
    809       ENDIF 
    810  
    811       IF (ln_vel3d) THEN 
    812  
    813          ! Set the number of variables for profiles to 2 (U and V) 
    814          nvelovars = 2 
    815  
    816          ! Set the number of extra variables for profiles to 2 to store  
    817          ! rotation parameters 
    818          nveloextr = 2 
    819  
    820          jveloset = 0 
    821           
    822          IF ( ln_velavcur ) jveloset = jveloset + 1 
    823          IF ( ln_velhrcur ) jveloset = jveloset + 1 
    824          IF ( ln_velavadcp ) jveloset = jveloset + 1 
    825          IF ( ln_velhradcp ) jveloset = jveloset + 1 
    826          IF (ln_velfb) jveloset = jveloset + jnumvelfb 
    827  
    828          nvelosets = jveloset 
    829          IF ( nvelosets > 0 ) THEN 
    830             ALLOCATE( velodata(nvelosets) ) 
    831             ALLOCATE( veldatqc(nvelosets) ) 
    832             ALLOCATE( ld_velav(nvelosets) ) 
    833          ENDIF 
    834           
    835          jveloset = 0 
    836           
    837          ! Daily averaged data 
    838  
    839          IF ( ln_velavcur ) THEN 
    840              
    841             jveloset = jveloset + 1 
    842              
    843             ld_velav(jveloset) = .TRUE. 
    844              
    845             CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelavcur, & 
    846                &                  velavcurfiles(1:jnumvelavcur), & 
    847                &                  nvelovars, nveloextr, & 
    848                &                  nitend-nit000+2,              & 
    849                &                  dobsini, dobsend, ln_ignmis, & 
    850                &                  ld_velav(jveloset), & 
    851                &                  .FALSE. ) 
    852              
    853             DO jvar = 1, 2 
    854                CALL obs_prof_staend( velodata(jveloset), jvar ) 
    855             END DO 
    856              
    857             CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 
    858                &              ln_vel3d, ln_nea, ld_velav(jveloset) ) 
    859              
    860          ENDIF 
    861  
    862          ! High frequency data 
    863  
    864          IF ( ln_velhrcur ) THEN 
    865              
    866             jveloset = jveloset + 1 
    867              
    868             ld_velav(jveloset) = .FALSE. 
    869                 
    870             CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelhrcur, & 
    871                &                  velhrcurfiles(1:jnumvelhrcur), & 
    872                &                  nvelovars, nveloextr, & 
    873                &                  nitend-nit000+2,              & 
    874                &                  dobsini, dobsend, ln_ignmis, & 
    875                &                  ld_velav(jveloset), & 
    876                &                  .FALSE. ) 
    877              
    878             DO jvar = 1, 2 
    879                CALL obs_prof_staend( velodata(jveloset), jvar ) 
    880             END DO 
    881              
    882             CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 
    883                &              ln_vel3d, ln_nea, ld_velav(jveloset) ) 
    884              
    885          ENDIF 
    886  
    887          ! Daily averaged data 
    888  
    889          IF ( ln_velavadcp ) THEN 
    890              
    891             jveloset = jveloset + 1 
    892              
    893             ld_velav(jveloset) = .TRUE. 
    894              
    895             CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelavadcp, & 
    896                &                  velavadcpfiles(1:jnumvelavadcp), & 
    897                &                  nvelovars, nveloextr, & 
    898                &                  nitend-nit000+2,              & 
    899                &                  dobsini, dobsend, ln_ignmis, & 
    900                &                  ld_velav(jveloset), & 
    901                &                  .FALSE. ) 
    902              
    903             DO jvar = 1, 2 
    904                CALL obs_prof_staend( velodata(jveloset), jvar ) 
    905             END DO 
    906              
    907             CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 
    908                &              ln_vel3d, ln_nea, ld_velav(jveloset) ) 
    909              
    910          ENDIF 
    911  
    912          ! High frequency data 
    913  
    914          IF ( ln_velhradcp ) THEN 
    915              
    916             jveloset = jveloset + 1 
    917              
    918             ld_velav(jveloset) = .FALSE. 
    919                 
    920             CALL obs_rea_vel_dri( 1, velodata(jveloset), jnumvelhradcp, & 
    921                &                  velhradcpfiles(1:jnumvelhradcp), & 
    922                &                  nvelovars, nveloextr, & 
    923                &                  nitend-nit000+2,              & 
    924                &                  dobsini, dobsend, ln_ignmis, & 
    925                &                  ld_velav(jveloset), & 
    926                &                  .FALSE. ) 
    927              
    928             DO jvar = 1, 2 
    929                CALL obs_prof_staend( velodata(jveloset), jvar ) 
    930             END DO 
    931              
    932             CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 
    933                &              ln_vel3d, ln_nea, ld_velav(jveloset) ) 
    934              
    935          ENDIF 
    936  
    937          IF ( ln_velfb ) THEN 
    938  
    939             DO jset = 1, jnumvelfb 
    940              
    941                jveloset = jveloset + 1 
    942  
    943                ld_velav(jveloset) = ln_velfb_av(jset) 
    944                 
    945                CALL obs_rea_vel_dri( 0, velodata(jveloset), 1, & 
    946                   &                  velfbfiles(jset:jset), & 
    947                   &                  nvelovars, nveloextr, & 
    948                   &                  nitend-nit000+2,              & 
    949                   &                  dobsini, dobsend, ln_ignmis, & 
    950                   &                  ld_velav(jveloset), & 
    951                   &                  .FALSE. ) 
    952                 
    953                DO jvar = 1, 2 
    954                   CALL obs_prof_staend( velodata(jveloset), jvar ) 
    955                END DO 
    956                 
    957                CALL obs_pre_vel( velodata(jveloset), veldatqc(jveloset), & 
    958                   &              ln_vel3d, ln_nea, ld_velav(jveloset) ) 
    959  
    960  
    961             END DO 
    962              
    963          ENDIF 
    964  
    965       ENDIF 
    966       
    967953   END SUBROUTINE dia_obs_init 
    968954 
    … …  
    974960      !! 
    975961      !! ** Method  : Call the observation operators on each time step to 
    976       !!              compute the model equivalent of the following date: 
    977       !!               - T profiles 
    978       !!               - S profiles 
    979       !!               - Sea surface height (referenced to a mean) 
    980       !!               - Sea surface temperature 
    981       !!               - Sea surface salinity 
    982       !!               - Velocity component (U,V) profiles 
     962      !!              compute the model equivalent of the following data: 
     963      !!               - Profile data, currently T/S or U/V 
     964      !!               - Surface data, currently SST, SLA or sea-ice concentration. 
    983965      !! 
    984       !! ** Action  :  
     966      !! ** Action  : 
    985967      !! 
    986968      !! History : 
    … …  
    991973      !!        !  07-04  (G. Smith) Generalized surface operators 
    992974      !!        !  08-10  (M. Valdivieso) obs operator for velocity profiles 
     975      !!        !  15-08  (M. Martin) Combined surface/profile routines. 
    993976      !!---------------------------------------------------------------------- 
    994977      !! * Modules used 
    995       USE dom_oce, ONLY : &             ! Ocean space and time domain variables 
    996          & rdt,           &                        
    997          & gdept_1d,       &              
    998          & tmask, umask, vmask                             
    999       USE phycst, ONLY : &              ! Physical constants 
    1000          & rday                          
    1001       USE oce, ONLY : &                 ! Ocean dynamics and tracers variables 
    1002          & tsn,  &              
    1003          & un, vn,  & 
     978      USE phycst, ONLY : &         ! Physical constants 
     979#if defined key_fabm 
     980         & rt0,          & 
     981#endif 
     982         & rday 
     983      USE oce, ONLY : &            ! Ocean dynamics and tracers variables 
     984         & tsn,       & 
     985         & un,        & 
     986         & vn,        & 
    1004987         & sshn 
    1005988#if defined  key_lim3 
    1006       USE ice, ONLY : &                     ! LIM Ice model variables 
     989      USE ice, ONLY : &            ! LIM3 Ice model variables 
    1007990         & frld 
    1008991#endif 
    1009992#if defined key_lim2 
    1010       USE ice_2, ONLY : &                     ! LIM Ice model variables 
     993      USE ice_2, ONLY : &          ! LIM2 Ice model variables 
    1011994         & frld 
    1012995#endif 
     996#if defined key_cice 
     997      USE sbc_oce, ONLY : fr_i     ! ice fraction 
     998#endif 
     999#if defined key_top 
     1000      USE trc, ONLY :  &           ! Biogeochemical state variables 
     1001         & trn 
     1002#endif 
     1003#if defined key_hadocc 
     1004      USE par_hadocc               ! HadOCC parameters 
     1005      USE trc, ONLY :  & 
     1006         & HADOCC_CHL, & 
     1007         & HADOCC_FCO2, & 
     1008         & HADOCC_PCO2, & 
     1009         & HADOCC_FILL_FLT 
     1010      USE had_bgc_const, ONLY: c2n_p 
     1011#elif defined key_medusa 
     1012      USE par_medusa               ! MEDUSA parameters 
     1013      USE sms_medusa, ONLY: & 
     1014         & xthetapn, & 
     1015         & xthetapd 
     1016#if defined key_roam 
     1017      USE sms_medusa, ONLY: & 
     1018         & f2_pco2w, & 
     1019         & f2_fco2w, & 
     1020         & f3_pH 
     1021#endif 
     1022#elif defined key_fabm 
     1023      USE par_fabm                 ! FABM parameters 
     1024      USE fabm, ONLY: & 
     1025         & fabm_get_interior_diagnostic_data 
     1026#endif 
     1027#if defined key_spm 
     1028      USE par_spm, ONLY: &         ! Sediment parameters 
     1029         & jp_spm 
     1030#endif 
     1031 
    10131032      IMPLICIT NONE 
    10141033 
    10151034      !! * Arguments 
    1016       INTEGER, INTENT(IN) :: kstp                         ! Current timestep 
     1035      INTEGER, INTENT(IN) :: kstp  ! Current timestep 
    10171036      !! * Local declarations 
    1018       INTEGER :: idaystp                ! Number of timesteps per day 
    1019       INTEGER :: jprofset               ! Profile data set loop variable 
    1020       INTEGER :: jslaset                ! SLA data set loop variable 
    1021       INTEGER :: jsstset                ! SST data set loop variable 
    1022       INTEGER :: jseaiceset             ! sea ice data set loop variable 
    1023       INTEGER :: jveloset               ! velocity profile data loop variable 
    1024       INTEGER :: jvar                   ! Variable number     
    1025 #if ! defined key_lim2 && ! defined key_lim3 
    1026       REAL(wp), POINTER, DIMENSION(:,:) :: frld    
    1027 #endif 
    1028       CHARACTER(LEN=20) :: datestr=" ",timestr=" " 
    1029   
    1030 #if ! defined key_lim2 && ! defined key_lim3 
    1031       CALL wrk_alloc(jpi,jpj,frld)  
    1032 #endif 
    1033  
     1037      INTEGER :: idaystp           ! Number of timesteps per day 
     1038      INTEGER :: imeanstp          ! Number of timesteps for sla averaging 
     1039      INTEGER :: jtype             ! Data loop variable 
     1040      INTEGER :: jvar              ! Variable number 
     1041      INTEGER :: ji, jj, jk        ! Loop counters 
     1042      REAL(wp) :: tiny             ! small number 
     1043      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: & 
     1044         & zprofvar, &             ! Model values for variables in a prof ob 
     1045         & zprofclim               ! Climatology values for variables in a prof ob 
     1046      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: & 
     1047         & zprofmask               ! Mask associated with zprofvar 
     1048      REAL(wp), POINTER, DIMENSION(:,:) :: & 
     1049         & zsurfvar, &             ! Model values equivalent to surface ob. 
     1050         & zsurfclim, &            ! Climatology values for variables in a surface ob. 
     1051         & zsurfmask               ! Mask associated with surface variable 
     1052      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     1053         & zglam,    &             ! Model longitudes for prof variables 
     1054         & zgphi                   ! Model latitudes for prof variables 
     1055      LOGICAL :: llog10            ! Perform log10 transform of variable 
     1056#if defined key_fabm 
     1057      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     1058         & fabm_3d                 ! 3D variable from FABM 
     1059#endif 
     1060       
    10341061      IF(lwp) THEN 
    10351062         WRITE(numout,*) 
    10361063         WRITE(numout,*) 'dia_obs : Call the observation operators', kstp 
    10371064         WRITE(numout,*) '~~~~~~~' 
     1065         CALL FLUSH(numout) 
    10381066      ENDIF 
    10391067 
    … …  
    10411069 
    10421070      !----------------------------------------------------------------------- 
    1043       ! No LIM => frld == 0.0_wp 
     1071      ! Call the profile and surface observation operators 
    10441072      !----------------------------------------------------------------------- 
    1045 #if ! defined key_lim2 && ! defined key_lim3 
    1046       frld(:,:) = 0.0_wp 
    1047 #endif 
    1048       !----------------------------------------------------------------------- 
    1049       ! Depending on switches call various observation operators 
    1050       !----------------------------------------------------------------------- 
    1051  
    1052       !  - Temperature/salinity profiles 
    1053       IF ( ln_t3d .OR. ln_s3d ) THEN 
    1054          DO jprofset = 1, nprofsets 
    1055             IF ( ld_enact(jprofset) ) THEN 
    1056                CALL obs_pro_opt( prodatqc(jprofset),                     & 
    1057                   &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
    1058                   &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
    1059                   &              gdept_1d, tmask, n1dint, n2dint,        & 
    1060                   &              kdailyavtypes = endailyavtypes ) 
     1073 
     1074      IF ( nproftypes > 0 ) THEN 
     1075 
     1076         DO jtype = 1, nproftypes 
     1077 
     1078            ! Allocate local work arrays 
     1079            CALL wrk_alloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofvar  ) 
     1080            CALL wrk_alloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofmask ) 
     1081            CALL wrk_alloc( jpi, jpj,      profdataqc(jtype)%nvar, zglam     ) 
     1082            CALL wrk_alloc( jpi, jpj,      profdataqc(jtype)%nvar, zgphi     ) 
     1083            CALL wrk_alloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofclim )     
     1084                               
     1085            ! Defaults which might change 
     1086            DO jvar = 1, profdataqc(jtype)%nvar 
     1087               zprofmask(:,:,:,jvar) = tmask(:,:,:) 
     1088               zglam(:,:,jvar)       = glamt(:,:) 
     1089               zgphi(:,:,jvar)       = gphit(:,:) 
     1090               zprofclim(:,:,:,jvar) = 0._wp 
     1091            END DO 
     1092 
     1093            SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 
     1094 
     1095            CASE('prof') 
     1096               zprofvar(:,:,:,1) = tsn(:,:,:,jp_tem) 
     1097               zprofvar(:,:,:,2) = tsn(:,:,:,jp_sal) 
     1098               IF ( ln_output_clim ) THEN           
     1099                  zprofclim(:,:,:,1) = tclim(:,:,:) 
     1100                  zprofclim(:,:,:,2) = sclim(:,:,:) 
     1101               ENDIF 
     1102                
     1103            CASE('vel') 
     1104               zprofvar(:,:,:,1) = un(:,:,:) 
     1105               zprofvar(:,:,:,2) = vn(:,:,:) 
     1106               zprofmask(:,:,:,1) = umask(:,:,:) 
     1107               zprofmask(:,:,:,2) = vmask(:,:,:) 
     1108               zglam(:,:,1) = glamu(:,:) 
     1109               zglam(:,:,2) = glamv(:,:) 
     1110               zgphi(:,:,1) = gphiu(:,:) 
     1111               zgphi(:,:,2) = gphiv(:,:) 
     1112 
     1113            CASE('plchltot') 
     1114#if defined key_hadocc 
     1115               ! Chlorophyll from HadOCC 
     1116               zprofvar(:,:,:,1) = HADOCC_CHL(:,:,:) 
     1117#elif defined key_medusa 
     1118               ! Add non-diatom and diatom chlorophyll from MEDUSA 
     1119               zprofvar(:,:,:,1) = trn(:,:,:,jpchn) + trn(:,:,:,jpchd) 
     1120#elif defined key_fabm 
     1121               ! Add all chlorophyll groups from ERSEM 
     1122               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_chl1) + trn(:,:,:,jp_fabm_m1+jp_fabm_chl2) + & 
     1123                  &                trn(:,:,:,jp_fabm_m1+jp_fabm_chl3) + trn(:,:,:,jp_fabm_m1+jp_fabm_chl4) 
     1124#else 
     1125               CALL ctl_stop( ' Trying to run plchltot observation operator', & 
     1126                  &           ' but no biogeochemical model appears to have been defined' ) 
     1127#endif 
     1128               ! Take the log10 where we can, otherwise exclude 
     1129               tiny = 1.0e-20 
     1130               WHERE(zprofvar(:,:,:,:) > tiny .AND. zprofvar(:,:,:,:) /= obfillflt ) 
     1131                  zprofvar(:,:,:,:)  = LOG10(zprofvar(:,:,:,:)) 
     1132               ELSEWHERE 
     1133                  zprofvar(:,:,:,:)  = obfillflt 
     1134                  zprofmask(:,:,:,:) = 0 
     1135               END WHERE 
     1136               ! Mask out model below any excluded values, 
     1137               ! to avoid interpolation issues 
     1138               DO jvar = 1, profdataqc(jtype)%nvar 
     1139                 DO jj = 1, jpj 
     1140                    DO ji = 1, jpi 
     1141                       depth_loop: DO jk = 1, jpk 
     1142                          IF ( zprofmask(ji,jj,jk,jvar) == 0 ) THEN 
     1143                             zprofmask(ji,jj,jk:jpk,jvar) = 0 
     1144                             EXIT depth_loop 
     1145                          ENDIF 
     1146                       END DO depth_loop 
     1147                    END DO 
     1148                 END DO 
     1149              END DO 
     1150 
     1151            CASE('pchltot') 
     1152#if defined key_hadocc 
     1153               ! Chlorophyll from HadOCC 
     1154               zprofvar(:,:,:,1) = HADOCC_CHL(:,:,:) 
     1155#elif defined key_medusa 
     1156               ! Add non-diatom and diatom chlorophyll from MEDUSA 
     1157               zprofvar(:,:,:,1) = trn(:,:,:,jpchn) + trn(:,:,:,jpchd) 
     1158#elif defined key_fabm 
     1159               ! Add all chlorophyll groups from ERSEM 
     1160               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_chl1) + trn(:,:,:,jp_fabm_m1+jp_fabm_chl2) + & 
     1161                  &                trn(:,:,:,jp_fabm_m1+jp_fabm_chl3) + trn(:,:,:,jp_fabm_m1+jp_fabm_chl4) 
     1162#else 
     1163               CALL ctl_stop( ' Trying to run pchltot observation operator', & 
     1164                  &           ' but no biogeochemical model appears to have been defined' ) 
     1165#endif 
     1166 
     1167            CASE('pno3') 
     1168#if defined key_hadocc 
     1169               ! Dissolved inorganic nitrogen from HadOCC 
     1170               zprofvar(:,:,:,1) = trn(:,:,:,jp_had_nut) 
     1171#elif defined key_medusa 
     1172               ! Dissolved inorganic nitrogen from MEDUSA 
     1173               zprofvar(:,:,:,1) = trn(:,:,:,jpdin) 
     1174#elif defined key_fabm 
     1175               ! Nitrate from ERSEM 
     1176               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_n3n) 
     1177#else 
     1178               CALL ctl_stop( ' Trying to run pno3 observation operator', & 
     1179                  &           ' but no biogeochemical model appears to have been defined' ) 
     1180#endif 
     1181 
     1182            CASE('psi4') 
     1183#if defined key_hadocc 
     1184               CALL ctl_stop( ' Trying to run psi4 observation operator', & 
     1185                  &           ' but HadOCC does not simulate silicate' ) 
     1186#elif defined key_medusa 
     1187               ! Silicate from MEDUSA 
     1188               zprofvar(:,:,:,1) = trn(:,:,:,jpsil) 
     1189#elif defined key_fabm 
     1190               ! Silicate from ERSEM 
     1191               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_n5s) 
     1192#else 
     1193               CALL ctl_stop( ' Trying to run psi4 observation operator', & 
     1194                  &           ' but no biogeochemical model appears to have been defined' ) 
     1195#endif 
     1196 
     1197            CASE('ppo4') 
     1198#if defined key_hadocc 
     1199               CALL ctl_stop( ' Trying to run ppo4 observation operator', & 
     1200                  &           ' but HadOCC does not simulate phosphate' ) 
     1201#elif defined key_medusa 
     1202               CALL ctl_stop( ' Trying to run ppo4 observation operator', & 
     1203                  &           ' but MEDUSA does not simulate phosphate' ) 
     1204#elif defined key_fabm 
     1205               ! Phosphate from ERSEM 
     1206               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_n1p) 
     1207#else 
     1208               CALL ctl_stop( ' Trying to run ppo4 observation operator', & 
     1209                  &           ' but no biogeochemical model appears to have been defined' ) 
     1210#endif 
     1211 
     1212            CASE('pdic') 
     1213#if defined key_hadocc 
     1214               ! Dissolved inorganic carbon from HadOCC 
     1215               zprofvar(:,:,:,1) = trn(:,:,:,jp_had_dic) 
     1216#elif defined key_medusa 
     1217               ! Dissolved inorganic carbon from MEDUSA 
     1218               zprofvar(:,:,:,1) = trn(:,:,:,jpdic) 
     1219#elif defined key_fabm 
     1220               ! Dissolved inorganic carbon from ERSEM 
     1221               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_o3c) 
     1222#else 
     1223               CALL ctl_stop( ' Trying to run pdic observation operator', & 
     1224                  &           ' but no biogeochemical model appears to have been defined' ) 
     1225#endif 
     1226 
     1227            CASE('palk') 
     1228#if defined key_hadocc 
     1229               ! Alkalinity from HadOCC 
     1230               zprofvar(:,:,:,1) = trn(:,:,:,jp_had_alk) 
     1231#elif defined key_medusa 
     1232               ! Alkalinity from MEDUSA 
     1233               zprofvar(:,:,:,1) = trn(:,:,:,jpalk) 
     1234#elif defined key_fabm 
     1235               ! Alkalinity from ERSEM 
     1236               zprofvar(:,:,:,1) = fabm_get_interior_diagnostic_data(model, jp_fabm_o3ta) 
     1237#else 
     1238               CALL ctl_stop( ' Trying to run palk observation operator', & 
     1239                  &           ' but no biogeochemical model appears to have been defined' ) 
     1240#endif 
     1241 
     1242            CASE('pph') 
     1243#if defined key_hadocc 
     1244               CALL ctl_stop( ' Trying to run pph observation operator', & 
     1245                  &           ' but HadOCC has no pH diagnostic defined' ) 
     1246#elif defined key_medusa && defined key_roam 
     1247               ! pH from MEDUSA 
     1248               zprofvar(:,:,:,1) = f3_pH(:,:,:) 
     1249#elif defined key_fabm 
     1250               ! pH from ERSEM 
     1251               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_o3ph) 
     1252#else 
     1253               CALL ctl_stop( ' Trying to run pph observation operator', & 
     1254                  &           ' but no biogeochemical model appears to have been defined' ) 
     1255#endif 
     1256 
     1257            CASE('po2') 
     1258#if defined key_hadocc 
     1259               CALL ctl_stop( ' Trying to run po2 observation operator', & 
     1260                  &           ' but HadOCC does not simulate oxygen' ) 
     1261#elif defined key_medusa 
     1262               ! Oxygen from MEDUSA 
     1263               zprofvar(:,:,:,1) = trn(:,:,:,jpoxy) 
     1264#elif defined key_fabm 
     1265               ! Oxygen from ERSEM 
     1266               zprofvar(:,:,:,1) = trn(:,:,:,jp_fabm_m1+jp_fabm_o2o) 
     1267#else 
     1268               CALL ctl_stop( ' Trying to run po2 observation operator', & 
     1269                  &           ' but no biogeochemical model appears to have been defined' ) 
     1270#endif 
     1271 
     1272            CASE DEFAULT 
     1273               CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) 
     1274 
     1275            END SELECT 
     1276 
     1277            DO jvar = 1, profdataqc(jtype)%nvar 
     1278               CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  & 
     1279                  &               nit000, idaystp, jvar,                   & 
     1280                  &               zprofvar(:,:,:,jvar),                    & 
     1281                  &               zprofclim(:,:,:,jvar),                   & 
     1282                  &               fsdept(:,:,:), fsdepw(:,:,:),            &  
     1283                  &               zprofmask(:,:,:,jvar),                   & 
     1284                  &               zglam(:,:,jvar), zgphi(:,:,jvar),        & 
     1285                  &               nn_1dint, nn_2dint_default,              & 
     1286                  &               kdailyavtypes = nn_profdavtypes ) 
     1287            END DO 
     1288 
     1289            CALL wrk_dealloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofvar  ) 
     1290            CALL wrk_dealloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofmask ) 
     1291            CALL wrk_dealloc( jpi, jpj,      profdataqc(jtype)%nvar, zglam     ) 
     1292            CALL wrk_dealloc( jpi, jpj,      profdataqc(jtype)%nvar, zgphi     ) 
     1293            CALL wrk_dealloc( jpi, jpj, jpk, profdataqc(jtype)%nvar, zprofclim  )             
     1294 
     1295         END DO 
     1296 
     1297      ENDIF 
     1298 
     1299      IF ( nsurftypes > 0 ) THEN 
     1300 
     1301         !Allocate local work arrays 
     1302         CALL wrk_alloc( jpi, jpj, zsurfvar ) 
     1303         CALL wrk_alloc( jpi, jpj, zsurfclim )          
     1304         CALL wrk_alloc( jpi, jpj, zsurfmask ) 
     1305#if defined key_fabm 
     1306         CALL wrk_alloc( jpi, jpj, jpk, fabm_3d ) 
     1307#endif 
     1308 
     1309         DO jtype = 1, nsurftypes 
     1310 
     1311            !Defaults which might be changed 
     1312            zsurfmask(:,:) = tmask(:,:,1) 
     1313            zsurfclim(:,:) = 0._wp           
     1314            llog10 = .FALSE. 
     1315 
     1316            SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 
     1317            CASE('sst') 
     1318               zsurfvar(:,:) = tsn(:,:,1,jp_tem) 
     1319               IF ( ln_output_clim ) zsurfclim(:,:) = tclim(:,:,1) 
     1320            CASE('sla') 
     1321               zsurfvar(:,:) = sshn(:,:) 
     1322            CASE('sss') 
     1323               zsurfvar(:,:) = tsn(:,:,1,jp_sal) 
     1324               IF ( ln_output_clim ) zsurfclim(:,:) = sclim(:,:,1)               
     1325            CASE('sic') 
     1326               IF ( kstp == 0 ) THEN 
     1327                  IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN 
     1328                     CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & 
     1329                        &           'time-step but some obs are valid then.' ) 
     1330                     WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & 
     1331                        &           ' sea-ice obs will be missed' 
     1332                  ENDIF 
     1333                  surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & 
     1334                     &                        surfdataqc(jtype)%nsstp(1) 
     1335                  CYCLE 
     1336               ELSE 
     1337#if defined key_cice 
     1338                  zsurfvar(:,:) = fr_i(:,:) 
     1339#elif defined key_lim2 || defined key_lim3 
     1340                  zsurfvar(:,:) = 1._wp - frld(:,:) 
     1341#else 
     1342               CALL ctl_stop( ' Trying to run sea-ice observation operator', & 
     1343                  &           ' but no sea-ice model appears to have been defined' ) 
     1344#endif 
     1345               ENDIF 
     1346 
     1347            CASE('slchltot') 
     1348#if defined key_hadocc 
     1349               ! Surface chlorophyll from HadOCC 
     1350               zsurfvar(:,:) = HADOCC_CHL(:,:,1) 
     1351#elif defined key_medusa 
     1352               ! Add non-diatom and diatom surface chlorophyll from MEDUSA 
     1353               zsurfvar(:,:) = trn(:,:,1,jpchn) + trn(:,:,1,jpchd) 
     1354#elif defined key_fabm 
     1355               ! Add all surface chlorophyll groups from ERSEM 
     1356               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl1) + trn(:,:,1,jp_fabm_m1+jp_fabm_chl2) + & 
     1357                  &            trn(:,:,1,jp_fabm_m1+jp_fabm_chl3) + trn(:,:,1,jp_fabm_m1+jp_fabm_chl4) 
     1358#else 
     1359               CALL ctl_stop( ' Trying to run slchltot observation operator', & 
     1360                  &           ' but no biogeochemical model appears to have been defined' ) 
     1361#endif 
     1362               llog10 = .TRUE. 
     1363 
     1364            CASE('slchldia') 
     1365#if defined key_hadocc 
     1366               CALL ctl_stop( ' Trying to run slchldia observation operator', & 
     1367                  &           ' but HadOCC does not explicitly simulate diatoms' ) 
     1368#elif defined key_medusa 
     1369               ! Diatom surface chlorophyll from MEDUSA 
     1370               zsurfvar(:,:) = trn(:,:,1,jpchd) 
     1371#elif defined key_fabm 
     1372               ! Diatom surface chlorophyll from ERSEM 
     1373               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl1) 
     1374#else 
     1375               CALL ctl_stop( ' Trying to run slchldia observation operator', & 
     1376                  &           ' but no biogeochemical model appears to have been defined' ) 
     1377#endif 
     1378               llog10 = .TRUE. 
     1379 
     1380            CASE('slchlnon') 
     1381#if defined key_hadocc 
     1382               CALL ctl_stop( ' Trying to run slchlnon observation operator', & 
     1383                  &           ' but HadOCC does not explicitly simulate non-diatoms' ) 
     1384#elif defined key_medusa 
     1385               ! Non-diatom surface chlorophyll from MEDUSA 
     1386               zsurfvar(:,:) = trn(:,:,1,jpchn) 
     1387#elif defined key_fabm 
     1388               ! Add all non-diatom surface chlorophyll groups from ERSEM 
     1389               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl2) + & 
     1390                  &            trn(:,:,1,jp_fabm_m1+jp_fabm_chl3) + trn(:,:,1,jp_fabm_m1+jp_fabm_chl4) 
     1391#else 
     1392               CALL ctl_stop( ' Trying to run slchlnon observation operator', & 
     1393                  &           ' but no biogeochemical model appears to have been defined' ) 
     1394#endif 
     1395               llog10 = .TRUE. 
     1396 
     1397            CASE('slchldin') 
     1398#if defined key_hadocc 
     1399               CALL ctl_stop( ' Trying to run slchldin observation operator', & 
     1400                  &           ' but HadOCC does not explicitly simulate dinoflagellates' ) 
     1401#elif defined key_medusa 
     1402               CALL ctl_stop( ' Trying to run slchldin observation operator', & 
     1403                  &           ' but MEDUSA does not explicitly simulate dinoflagellates' ) 
     1404#elif defined key_fabm 
     1405               ! Dinoflagellate surface chlorophyll from ERSEM 
     1406               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl4) 
     1407#else 
     1408               CALL ctl_stop( ' Trying to run slchldin observation operator', & 
     1409                  &           ' but no biogeochemical model appears to have been defined' ) 
     1410#endif 
     1411               llog10 = .TRUE. 
     1412 
     1413            CASE('slchlmic') 
     1414#if defined key_hadocc 
     1415               CALL ctl_stop( ' Trying to run slchlmic observation operator', & 
     1416                  &           ' but HadOCC does not explicitly simulate microphytoplankton' ) 
     1417#elif defined key_medusa 
     1418               CALL ctl_stop( ' Trying to run slchlmic observation operator', & 
     1419                  &           ' but MEDUSA does not explicitly simulate microphytoplankton' ) 
     1420#elif defined key_fabm 
     1421               ! Add diatom and dinoflagellate surface chlorophyll from ERSEM 
     1422               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl1) + trn(:,:,1,jp_fabm_m1+jp_fabm_chl4) 
     1423#else 
     1424               CALL ctl_stop( ' Trying to run slchlmic observation operator', & 
     1425                  &           ' but no biogeochemical model appears to have been defined' ) 
     1426#endif 
     1427               llog10 = .TRUE. 
     1428 
     1429            CASE('slchlnan') 
     1430#if defined key_hadocc 
     1431               CALL ctl_stop( ' Trying to run slchlnan observation operator', & 
     1432                  &           ' but HadOCC does not explicitly simulate nanophytoplankton' ) 
     1433#elif defined key_medusa 
     1434               CALL ctl_stop( ' Trying to run slchlnan observation operator', & 
     1435                  &           ' but MEDUSA does not explicitly simulate nanophytoplankton' ) 
     1436#elif defined key_fabm 
     1437               ! Nanophytoplankton surface chlorophyll from ERSEM 
     1438               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl2) 
     1439#else 
     1440               CALL ctl_stop( ' Trying to run slchlnan observation operator', & 
     1441                  &           ' but no biogeochemical model appears to have been defined' ) 
     1442#endif 
     1443               llog10 = .TRUE. 
     1444 
     1445            CASE('slchlpic') 
     1446#if defined key_hadocc 
     1447               CALL ctl_stop( ' Trying to run slchlpic observation operator', & 
     1448                  &           ' but HadOCC does not explicitly simulate picophytoplankton' ) 
     1449#elif defined key_medusa 
     1450               CALL ctl_stop( ' Trying to run slchlpic observation operator', & 
     1451                  &           ' but MEDUSA does not explicitly simulate picophytoplankton' ) 
     1452#elif defined key_fabm 
     1453               ! Picophytoplankton surface chlorophyll from ERSEM 
     1454               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl3) 
     1455#else 
     1456               CALL ctl_stop( ' Trying to run slchlpic observation operator', & 
     1457                  &           ' but no biogeochemical model appears to have been defined' ) 
     1458#endif 
     1459               llog10 = .TRUE. 
     1460 
     1461            CASE('schltot') 
     1462#if defined key_hadocc 
     1463               ! Surface chlorophyll from HadOCC 
     1464               zsurfvar(:,:) = HADOCC_CHL(:,:,1) 
     1465#elif defined key_medusa 
     1466               ! Add non-diatom and diatom surface chlorophyll from MEDUSA 
     1467               zsurfvar(:,:) = trn(:,:,1,jpchn) + trn(:,:,1,jpchd) 
     1468#elif defined key_fabm 
     1469               ! Add all surface chlorophyll groups from ERSEM 
     1470               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_chl1) + trn(:,:,1,jp_fabm_m1+jp_fabm_chl2) + & 
     1471                  &            trn(:,:,1,jp_fabm_m1+jp_fabm_chl3) + trn(:,:,1,jp_fabm_m1+jp_fabm_chl4) 
     1472#else 
     1473               CALL ctl_stop( ' Trying to run schltot observation operator', & 
     1474                  &           ' but no biogeochemical model appears to have been defined' ) 
     1475#endif 
     1476 
     1477            CASE('slphytot') 
     1478#if defined key_hadocc 
     1479               ! Surface phytoplankton nitrogen from HadOCC multiplied by C:N ratio 
     1480               zsurfvar(:,:) = trn(:,:,1,jp_had_phy) * c2n_p 
     1481#elif defined key_medusa 
     1482               ! Add non-diatom and diatom surface phytoplankton nitrogen from MEDUSA 
     1483               ! multiplied by C:N ratio for each 
     1484               zsurfvar(:,:) = (trn(:,:,1,jpphn) * xthetapn) + (trn(:,:,1,jpphd) * xthetapd) 
     1485#elif defined key_fabm 
     1486               ! Add all surface phytoplankton carbon groups from ERSEM 
     1487               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_p1c) + trn(:,:,1,jp_fabm_m1+jp_fabm_p2c) + & 
     1488                  &            trn(:,:,1,jp_fabm_m1+jp_fabm_p3c) + trn(:,:,1,jp_fabm_m1+jp_fabm_p4c) 
     1489#else 
     1490               CALL ctl_stop( ' Trying to run slphytot observation operator', & 
     1491                  &           ' but no biogeochemical model appears to have been defined' ) 
     1492#endif 
     1493               llog10 = .TRUE. 
     1494 
     1495            CASE('slphydia') 
     1496#if defined key_hadocc 
     1497               CALL ctl_stop( ' Trying to run slphydia observation operator', & 
     1498                  &           ' but HadOCC does not explicitly simulate diatoms' ) 
     1499#elif defined key_medusa 
     1500               ! Diatom surface phytoplankton nitrogen from MEDUSA multiplied by C:N ratio 
     1501               zsurfvar(:,:) = trn(:,:,1,jpphd) * xthetapd 
     1502#elif defined key_fabm 
     1503               ! Diatom surface phytoplankton carbon from ERSEM 
     1504               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_p1c) 
     1505#else 
     1506               CALL ctl_stop( ' Trying to run slphydia observation operator', & 
     1507                  &           ' but no biogeochemical model appears to have been defined' ) 
     1508#endif 
     1509               llog10 = .TRUE. 
     1510 
     1511            CASE('slphynon') 
     1512#if defined key_hadocc 
     1513               CALL ctl_stop( ' Trying to run slphynon observation operator', & 
     1514                  &           ' but HadOCC does not explicitly simulate non-diatoms' ) 
     1515#elif defined key_medusa 
     1516               ! Non-diatom surface phytoplankton nitrogen from MEDUSA multiplied by C:N ratio 
     1517               zsurfvar(:,:) = trn(:,:,1,jpphn) * xthetapn 
     1518#elif defined key_fabm 
     1519               ! Add all non-diatom surface phytoplankton carbon groups from ERSEM 
     1520               zsurfvar(:,:) = trn(:,:,1,jp_fabm_m1+jp_fabm_p2c) + & 
     1521                  &            trn(:,:,1,jp_fabm_m1+jp_fabm_p3c) + trn(:,:,1,jp_fabm_m1+jp_fabm_p4c) 
     1522#else 
     1523               CALL ctl_stop( ' Trying to run slphynon observation operator', & 
     1524                  &           ' but no biogeochemical model appears to have been defined' ) 
     1525#endif 
     1526               llog10 = .TRUE. 
     1527 
     1528            CASE('sspm') 
     1529#if defined key_spm 
     1530               zsurfvar(:,:) = 0.0 
     1531               DO jn = 1, jp_spm 
     1532                  zsurfvar(:,:) = zsurfvar(:,:) + trn(:,:,1,jn)   ! sum SPM sizes 
     1533               END DO 
     1534#else 
     1535               CALL ctl_stop( ' Trying to run sspm observation operator', & 
     1536                  &           ' but no spm model appears to have been defined' ) 
     1537#endif 
     1538 
     1539            CASE('skd490') 
     1540#if defined key_hadocc 
     1541               CALL ctl_stop( ' Trying to run skd490 observation operator', & 
     1542                  &           ' but HadOCC does not explicitly simulate Kd490' ) 
     1543#elif defined key_medusa 
     1544               CALL ctl_stop( ' Trying to run skd490 observation operator', & 
     1545                  &           ' but MEDUSA does not explicitly simulate Kd490' ) 
     1546#elif defined key_fabm 
     1547               ! light_xEPS diagnostic variable 
     1548               fabm_3d(:,:,:) = fabm_get_interior_diagnostic_data(model, jp_fabm_xeps) 
     1549               zsurfvar(:,:) = fabm_3d(:,:,1) 
     1550#else 
     1551               CALL ctl_stop( ' Trying to run skd490 observation operator', & 
     1552                  &           ' but no biogeochemical model appears to have been defined' ) 
     1553#endif 
     1554 
     1555            CASE('sfco2') 
     1556#if defined key_hadocc 
     1557               zsurfvar(:,:) = HADOCC_FCO2(:,:)    ! fCO2 from HadOCC 
     1558               IF ( ( MINVAL( HADOCC_FCO2 ) == HADOCC_FILL_FLT ) .AND. & 
     1559                  & ( MAXVAL( HADOCC_FCO2 ) == HADOCC_FILL_FLT ) ) THEN 
     1560                  zsurfvar(:,:) = obfillflt 
     1561                  zsurfmask(:,:) = 0 
     1562                  CALL ctl_warn( ' HadOCC fCO2 values masked out for observation operator', & 
     1563                     &           ' as HADOCC_FCO2(:,:) == HADOCC_FILL_FLT' ) 
     1564               ENDIF 
     1565#elif defined key_medusa && defined key_roam 
     1566               zsurfvar(:,:) = f2_fco2w(:,:) 
     1567#elif defined key_fabm 
     1568               ! First, get pCO2 from FABM 
     1569               fabm_3d(:,:,:) = fabm_get_interior_diagnostic_data(model, jp_fabm_o3pc) 
     1570               zsurfvar(:,:) = fabm_3d(:,:,1) 
     1571               ! Now, convert pCO2 to fCO2, based on SST in K. This follows the standard methodology of: 
     1572               ! Pierrot et al. (2009), Recommendations for autonomous underway pCO2 measuring systems 
     1573               ! and data reduction routines, Deep-Sea Research II, 56: 512-522. 
     1574               ! and 
     1575               ! Weiss (1974), Carbon dioxide in water and seawater: the solubility of a non-ideal gas, 
     1576               ! Marine Chemistry, 2: 203-215. 
     1577               ! In the implementation below, atmospheric pressure has been assumed to be 1 atm and so 
     1578               ! not explicitly included - atmospheric pressure is not necessarily available so this is 
     1579               ! the best assumption. 
     1580               ! Further, the (1-xCO2)^2 term has been neglected. This is common practice 
     1581               ! (see e.g. Zeebe and Wolf-Gladrow (2001), CO2 in Seawater: Equilibrium, Kinetics, Isotopes) 
     1582               ! because xCO2 in atm is ~0, and so this term will only affect the result to the 3rd decimal 
     1583               ! place for typical values, and xCO2 would need to be approximated from pCO2 anyway. 
     1584               zsurfvar(:,:) = zsurfvar(:,:) * EXP((-1636.75                                                          + & 
     1585                  &            12.0408      * (tsn(:,:,1,jp_tem)+rt0)                                                 - & 
     1586                  &            0.0327957    * (tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0)                         + & 
     1587                  &            0.0000316528 * (tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0)*(tsn(:,:,1,jp_tem)+rt0) + & 
     1588                  &            2.0 * (57.7 - 0.118 * (tsn(:,:,1,jp_tem)+rt0)))                                        / & 
     1589                  &            (82.0578 * (tsn(:,:,1,jp_tem)+rt0))) 
     1590#else 
     1591               CALL ctl_stop( ' Trying to run sfco2 observation operator', & 
     1592                  &           ' but no biogeochemical model appears to have been defined' ) 
     1593#endif 
     1594 
     1595            CASE('spco2') 
     1596#if defined key_hadocc 
     1597               zsurfvar(:,:) = HADOCC_PCO2(:,:)    ! pCO2 from HadOCC 
     1598               IF ( ( MINVAL( HADOCC_PCO2 ) == HADOCC_FILL_FLT ) .AND. & 
     1599                  & ( MAXVAL( HADOCC_PCO2 ) == HADOCC_FILL_FLT ) ) THEN 
     1600                  zsurfvar(:,:) = obfillflt 
     1601                  zsurfmask(:,:) = 0 
     1602                  CALL ctl_warn( ' HadOCC pCO2 values masked out for observation operator', & 
     1603                     &           ' as HADOCC_PCO2(:,:) == HADOCC_FILL_FLT' ) 
     1604               ENDIF 
     1605#elif defined key_medusa && defined key_roam 
     1606               zsurfvar(:,:) = f2_pco2w(:,:) 
     1607#elif defined key_fabm 
     1608               fabm_3d(:,:,:) = fabm_get_interior_diagnostic_data(model, jp_fabm_o3pc) 
     1609               zsurfvar(:,:) = fabm_3d(:,:,1) 
     1610#else 
     1611               CALL ctl_stop( ' Trying to run spco2 observation operator', & 
     1612                  &           ' but no biogeochemical model appears to have been defined' ) 
     1613#endif 
     1614 
     1615            CASE DEFAULT 
     1616 
     1617               CALL ctl_stop( 'Unknown surface observation type '//TRIM(cobstypessurf(jtype))//' in dia_obs' ) 
     1618 
     1619            END SELECT 
     1620             
     1621            IF ( llog10 ) THEN 
     1622               ! Take the log10 where we can, otherwise exclude 
     1623               tiny = 1.0e-20 
     1624               WHERE(zsurfvar(:,:) > tiny .AND. zsurfvar(:,:) /= obfillflt ) 
     1625                  zsurfvar(:,:)  = LOG10(zsurfvar(:,:)) 
     1626               ELSEWHERE 
     1627                  zsurfvar(:,:)  = obfillflt 
     1628                  zsurfmask(:,:) = 0 
     1629               END WHERE 
     1630            ENDIF 
     1631 
     1632            IF ( TRIM(cobstypessurf(jtype)) == 'sla' .AND.                 & 
     1633                  &  ln_time_mean_sla_bkg ) THEN 
     1634               !Number of time-steps in meaning period 
     1635               imeanstp = NINT( ( MeanPeriodHours * 60. * 60. ) / rdt ) 
     1636               CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj,       & 
     1637                  &               nit000, idaystp, zsurfvar,               & 
     1638                  &               zsurfclim, zsurfmask,                    & 
     1639                  &               n2dintsurf(jtype), llnightav(jtype),     & 
     1640                  &               ravglamscl(jtype), ravgphiscl(jtype),    & 
     1641                  &               lfpindegs(jtype), kmeanstp = imeanstp ) 
     1642 
    10611643            ELSE 
    1062                CALL obs_pro_opt( prodatqc(jprofset),                     & 
    1063                   &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
    1064                   &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
    1065                   &              gdept_1d, tmask, n1dint, n2dint              ) 
     1644               CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj,       & 
     1645                  &               nit000, idaystp, zsurfvar,               & 
     1646                  &               zsurfclim, zsurfmask,                    & 
     1647                  &               n2dintsurf(jtype), llnightav(jtype),     & 
     1648                  &               ravglamscl(jtype), ravgphiscl(jtype),    & 
     1649                  &               lfpindegs(jtype) ) 
    10661650            ENDIF 
     1651 
    10671652         END DO 
     1653 
     1654         CALL wrk_dealloc( jpi, jpj, zsurfvar ) 
     1655         CALL wrk_dealloc( jpi, jpj, zsurfmask ) 
     1656#if defined key_fabm 
     1657         CALL wrk_dealloc( jpi, jpj, jpk, fabm_3d ) 
     1658#endif 
     1659 
    10681660      ENDIF 
    10691661 
    1070       !  - Sea surface anomaly 
    1071       IF ( ln_sla ) THEN 
    1072          DO jslaset = 1, nslasets 
    1073             CALL obs_sla_opt( sladatqc(jslaset),            & 
    1074                &              kstp, jpi, jpj, nit000, sshn, & 
    1075                &              tmask(:,:,1), n2dint ) 
    1076          END DO          
    1077       ENDIF 
    1078  
    1079       !  - Sea surface temperature 
    1080       IF ( ln_sst ) THEN 
    1081          DO jsstset = 1, nsstsets 
    1082             CALL obs_sst_opt( sstdatqc(jsstset),                & 
    1083                &              kstp, jpi, jpj, nit000, idaystp,  & 
    1084                &              tsn(:,:,1,jp_tem), tmask(:,:,1),  & 
    1085                &              n2dint, ld_sstnight(jsstset) ) 
    1086          END DO 
    1087       ENDIF 
    1088  
    1089       !  - Sea surface salinity 
    1090       IF ( ln_sss ) THEN 
    1091          IF(lwp) WRITE(numout,*) ' SSS currently not available' 
    1092       ENDIF 
    1093  
    1094 #if defined key_lim2 || defined key_lim3 
    1095       IF ( ln_seaice ) THEN 
    1096          DO jseaiceset = 1, nseaicesets 
    1097             CALL obs_seaice_opt( seaicedatqc(jseaiceset),      & 
    1098                &              kstp, jpi, jpj, nit000, 1.-frld, & 
    1099                &              tmask(:,:,1), n2dint ) 
    1100          END DO 
    1101       ENDIF       
    1102 #endif 
    1103  
    1104       !  - Velocity profiles 
    1105       IF ( ln_vel3d ) THEN 
    1106          DO jveloset = 1, nvelosets 
    1107            ! zonal component of velocity 
    1108            CALL obs_vel_opt( veldatqc(jveloset), kstp, jpi, jpj, jpk, & 
    1109               &              nit000, idaystp, un, vn, gdept_1d, umask, vmask, & 
    1110                              n1dint, n2dint, ld_velav(jveloset) ) 
    1111          END DO 
    1112       ENDIF 
    1113  
    1114 #if ! defined key_lim2 && ! defined key_lim3 
    1115       CALL wrk_dealloc(jpi,jpj,frld)  
    1116 #endif 
    1117  
    11181662   END SUBROUTINE dia_obs 
    1119    
    1120    SUBROUTINE dia_obs_wri  
     1663 
     1664   SUBROUTINE dia_obs_wri 
    11211665      !!---------------------------------------------------------------------- 
    11221666      !!                    ***  ROUTINE dia_obs_wri  *** 
    … …  
    11261670      !! ** Method  : Call observation diagnostic output routines 
    11271671      !! 
    1128       !! ** Action  :  
     1672      !! ** Action  : 
    11291673      !! 
    11301674      !! History : 
    … …  
    11341678      !!        !  07-03  (K. Mogensen) General handling of profiles 
    11351679      !!        !  08-09  (M. Valdivieso) Velocity component (U,V) profiles 
     1680      !!        !  15-08  (M. Martin) Combined writing for prof and surf types 
    11361681      !!---------------------------------------------------------------------- 
     1682      !! * Modules used 
     1683      USE obs_rot_vel          ! Rotation of velocities 
     1684 
    11371685      IMPLICIT NONE 
    11381686 
    11391687      !! * Local declarations 
    1140  
    1141       INTEGER :: jprofset                 ! Profile data set loop variable 
    1142       INTEGER :: jveloset                 ! Velocity data set loop variable 
    1143       INTEGER :: jslaset                  ! SLA data set loop variable 
    1144       INTEGER :: jsstset                  ! SST data set loop variable 
    1145       INTEGER :: jseaiceset               ! Sea Ice data set loop variable 
    1146       INTEGER :: jset 
    1147       INTEGER :: jfbini 
    1148       CHARACTER(LEN=20) :: datestr=" ",timestr=" " 
    1149       CHARACTER(LEN=10) :: cdtmp 
     1688      INTEGER :: jtype                    ! Data set loop variable 
     1689      INTEGER :: jo, jvar, jk 
     1690      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
     1691         & zu, & 
     1692         & zv 
     1693 
    11501694      !----------------------------------------------------------------------- 
    11511695      ! Depending on switches call various observation output routines 
    11521696      !----------------------------------------------------------------------- 
    11531697 
    1154       !  - Temperature/salinity profiles 
    1155  
    1156       IF( ln_t3d .OR. ln_s3d ) THEN 
    1157  
    1158          ! Copy data from prodatqc to profdata structures 
    1159          DO jprofset = 1, nprofsets 
    1160  
    1161             CALL obs_prof_decompress( prodatqc(jprofset), & 
    1162                  &                    profdata(jprofset), .TRUE., numout ) 
     1698      IF ( nproftypes > 0 ) THEN 
     1699 
     1700         DO jtype = 1, nproftypes 
     1701 
     1702            IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 
     1703 
     1704               ! For velocity data, rotate the model velocities to N/S, E/W 
     1705               ! using the compressed data structure. 
     1706               ALLOCATE( & 
     1707                  & zu(profdataqc(jtype)%nvprot(1)), & 
     1708                  & zv(profdataqc(jtype)%nvprot(2))  & 
     1709                  & ) 
     1710 
     1711               CALL obs_rotvel( profdataqc(jtype), nn_2dint_default, zu, zv ) 
     1712 
     1713               DO jo = 1, profdataqc(jtype)%nprof 
     1714                  DO jvar = 1, 2 
     1715                     DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) 
     1716 
     1717                        IF ( jvar == 1 ) THEN 
     1718                           profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) 
     1719                        ELSE 
     1720                           profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) 
     1721                        ENDIF 
     1722 
     1723                     END DO 
     1724                  END DO 
     1725               END DO 
     1726 
     1727               DEALLOCATE( zu ) 
     1728               DEALLOCATE( zv ) 
     1729 
     1730            END IF 
     1731 
     1732            CALL obs_prof_decompress( profdataqc(jtype), & 
     1733               &                      profdata(jtype), .TRUE., numout ) 
     1734 
     1735            CALL obs_wri_prof( profdata(jtype) ) 
    11631736 
    11641737         END DO 
    11651738 
    1166          ! Write the profiles. 
    1167  
    1168          jprofset = 0 
    1169  
    1170          ! ENACT insitu data 
    1171  
    1172          IF ( ln_ena ) THEN 
    1173             
    1174             jprofset = jprofset + 1 
    1175  
    1176             CALL obs_wri_p3d( 'enact', profdata(jprofset) ) 
    1177  
    1178          ENDIF 
    1179  
    1180          ! Coriolis insitu data 
    1181  
    1182          IF ( ln_cor ) THEN 
    1183              
    1184             jprofset = jprofset + 1 
    1185  
    1186             CALL obs_wri_p3d( 'corio', profdata(jprofset) ) 
    1187              
    1188          ENDIF 
    1189           
    1190          ! Feedback insitu data 
    1191  
    1192          IF ( ln_profb ) THEN 
    1193  
    1194             jfbini = jprofset + 1 
    1195  
    1196             DO jprofset = jfbini, nprofsets 
    1197                 
    1198                jset = jprofset - jfbini + 1 
    1199                WRITE(cdtmp,'(A,I2.2)')'profb_',jset 
    1200                CALL obs_wri_p3d( cdtmp, profdata(jprofset) ) 
    1201  
    1202             END DO 
    1203  
    1204          ENDIF 
    1205  
    12061739      ENDIF 
    12071740 
    1208       !  - Sea surface anomaly 
    1209       IF ( ln_sla ) THEN 
    1210  
    1211          ! Copy data from sladatqc to sladata structures 
    1212          DO jslaset = 1, nslasets 
    1213  
    1214               CALL obs_surf_decompress( sladatqc(jslaset), & 
    1215                  &                    sladata(jslaset), .TRUE., numout ) 
     1741      IF ( nsurftypes > 0 ) THEN 
     1742 
     1743         DO jtype = 1, nsurftypes 
     1744 
     1745            CALL obs_surf_decompress( surfdataqc(jtype), & 
     1746               &                      surfdata(jtype), .TRUE., numout ) 
     1747 
     1748            CALL obs_wri_surf( surfdata(jtype) ) 
    12161749 
    12171750         END DO 
    12181751 
    1219          jslaset = 0  
    1220  
    1221          ! Write the AVISO SLA data 
    1222  
    1223          IF ( ln_sladt ) THEN 
    1224              
    1225             jslaset = 1 
    1226             CALL obs_wri_sla( 'aviso_act', sladata(jslaset) ) 
    1227             jslaset = 2 
    1228             CALL obs_wri_sla( 'aviso_pas', sladata(jslaset) ) 
    1229  
    1230          ENDIF 
    1231  
    1232          IF ( ln_slafb ) THEN 
    1233              
    1234             jfbini = jslaset + 1 
    1235  
    1236             DO jslaset = jfbini, nslasets 
    1237                 
    1238                jset = jslaset - jfbini + 1 
    1239                WRITE(cdtmp,'(A,I2.2)')'slafb_',jset 
    1240                CALL obs_wri_sla( cdtmp, sladata(jslaset) ) 
    1241  
    1242             END DO 
    1243  
    1244          ENDIF 
    1245  
    1246       ENDIF 
    1247  
    1248       !  - Sea surface temperature 
    1249       IF ( ln_sst ) THEN 
    1250  
    1251          ! Copy data from sstdatqc to sstdata structures 
    1252          DO jsstset = 1, nsstsets 
    1253       
    1254               CALL obs_surf_decompress( sstdatqc(jsstset), & 
    1255                  &                    sstdata(jsstset), .TRUE., numout ) 
    1256  
    1257          END DO 
    1258  
    1259          jsstset = 0  
    1260  
    1261          ! Write the AVISO SST data 
    1262  
    1263          IF ( ln_reysst ) THEN 
    1264              
    1265             jsstset = jsstset + 1 
    1266             CALL obs_wri_sst( 'reynolds', sstdata(jsstset) ) 
    1267  
    1268          ENDIF 
    1269  
    1270          IF ( ln_ghrsst ) THEN 
    1271              
    1272             jsstset = jsstset + 1 
    1273             CALL obs_wri_sst( 'ghr', sstdata(jsstset) ) 
    1274  
    1275          ENDIF 
    1276  
    1277          IF ( ln_sstfb ) THEN 
    1278              
    1279             jfbini = jsstset + 1 
    1280  
    1281             DO jsstset = jfbini, nsstsets 
    1282                 
    1283                jset = jsstset - jfbini + 1 
    1284                WRITE(cdtmp,'(A,I2.2)')'sstfb_',jset 
    1285                CALL obs_wri_sst( cdtmp, sstdata(jsstset) ) 
    1286  
    1287             END DO 
    1288  
    1289          ENDIF 
    1290  
    1291       ENDIF 
    1292  
    1293       !  - Sea surface salinity 
    1294       IF ( ln_sss ) THEN 
    1295          IF(lwp) WRITE(numout,*) ' SSS currently not available' 
    1296       ENDIF 
    1297  
    1298       !  - Sea Ice Concentration 
    1299       IF ( ln_seaice ) THEN 
    1300  
    1301          ! Copy data from seaicedatqc to seaicedata structures 
    1302          DO jseaiceset = 1, nseaicesets 
    1303  
    1304               CALL obs_surf_decompress( seaicedatqc(jseaiceset), & 
    1305                  &                    seaicedata(jseaiceset), .TRUE., numout ) 
    1306  
    1307          END DO 
    1308  
    1309          ! Write the Sea Ice data 
    1310          DO jseaiceset = 1, nseaicesets 
    1311        
    1312             WRITE(cdtmp,'(A,I2.2)')'seaicefb_',jseaiceset 
    1313             CALL obs_wri_seaice( cdtmp, seaicedata(jseaiceset) ) 
    1314  
    1315          END DO 
    1316  
    1317       ENDIF 
    1318        
    1319       ! Velocity data 
    1320       IF( ln_vel3d ) THEN 
    1321  
    1322          ! Copy data from veldatqc to velodata structures 
    1323          DO jveloset = 1, nvelosets 
    1324  
    1325             CALL obs_prof_decompress( veldatqc(jveloset), & 
    1326                  &                    velodata(jveloset), .TRUE., numout ) 
    1327  
    1328          END DO 
    1329  
    1330          ! Write the profiles. 
    1331  
    1332          jveloset = 0 
    1333  
    1334          ! Daily averaged data 
    1335  
    1336          IF ( ln_velavcur ) THEN 
    1337              
    1338             jveloset = jveloset + 1 
    1339  
    1340             CALL obs_wri_vel( 'velavcurr', velodata(jveloset), n2dint ) 
    1341  
    1342          ENDIF 
    1343  
    1344          ! High frequency data 
    1345  
    1346          IF ( ln_velhrcur ) THEN 
    1347              
    1348             jveloset = jveloset + 1 
    1349  
    1350             CALL obs_wri_vel( 'velhrcurr', velodata(jveloset), n2dint ) 
    1351  
    1352          ENDIF 
    1353  
    1354          ! Daily averaged data 
    1355  
    1356          IF ( ln_velavadcp ) THEN 
    1357              
    1358             jveloset = jveloset + 1 
    1359  
    1360             CALL obs_wri_vel( 'velavadcp', velodata(jveloset), n2dint ) 
    1361  
    1362          ENDIF 
    1363  
    1364          ! High frequency data 
    1365  
    1366          IF ( ln_velhradcp ) THEN 
    1367              
    1368             jveloset = jveloset + 1 
    1369              
    1370             CALL obs_wri_vel( 'velhradcp', velodata(jveloset), n2dint ) 
    1371                 
    1372          ENDIF 
    1373  
    1374          ! Feedback velocity data 
    1375  
    1376          IF ( ln_velfb ) THEN 
    1377  
    1378             jfbini = jveloset + 1 
    1379  
    1380             DO jveloset = jfbini, nvelosets 
    1381                 
    1382                jset = jveloset - jfbini + 1 
    1383                WRITE(cdtmp,'(A,I2.2)')'velfb_',jset 
    1384                CALL obs_wri_vel( cdtmp, velodata(jveloset), n2dint ) 
    1385  
    1386             END DO 
    1387  
    1388          ENDIF 
    1389           
    13901752      ENDIF 
    13911753 
    … …  
    14051767      !! 
    14061768      !!---------------------------------------------------------------------- 
    1407       !! obs_grid deallocation 
     1769      ! obs_grid deallocation 
    14081770      CALL obs_grid_deallocate 
    14091771 
    1410       !! diaobs deallocation 
    1411       IF ( nprofsets > 0 ) THEN 
    1412           DEALLOCATE(ld_enact, & 
    1413                   &  profdata, & 
    1414                   &  prodatqc) 
    1415       END IF 
    1416       IF ( ln_sla ) THEN 
    1417           DEALLOCATE(sladata, & 
    1418                   &  sladatqc) 
    1419       END IF 
    1420       IF ( ln_seaice ) THEN 
    1421           DEALLOCATE(sladata, & 
    1422                   &  sladatqc) 
    1423       END IF 
    1424       IF ( ln_sst ) THEN 
    1425           DEALLOCATE(sstdata, & 
    1426                   &  sstdatqc) 
    1427       END IF 
    1428       IF ( ln_vel3d ) THEN 
    1429           DEALLOCATE(ld_velav, & 
    1430                   &  velodata, & 
    1431                   &  veldatqc) 
    1432       END IF 
     1772      ! diaobs deallocation 
     1773      IF ( nproftypes > 0 ) & 
     1774         &   DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) 
     1775 
     1776      IF ( nsurftypes > 0 ) & 
     1777         &   DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf, & 
     1778         &               n2dintsurf, ravglamscl, ravgphiscl, lfpindegs, llnightav ) 
     1779 
    14331780   END SUBROUTINE dia_obs_dealloc 
    14341781 
    … …  
    14361783      !!---------------------------------------------------------------------- 
    14371784      !!                    ***  ROUTINE ini_date  *** 
    1438       !!           
    1439       !! ** Purpose : Get initial data in double precision YYYYMMDD.HHMMSS format 
    14401785      !! 
    1441       !! ** Method  : Get initial data in double precision YYYYMMDD.HHMMSS format 
     1786      !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format 
    14421787      !! 
    1443       !! ** Action  : Get initial data in double precision YYYYMMDD.HHMMSS format 
     1788      !! ** Method  : Get initial date in double precision YYYYMMDD.HHMMSS format 
     1789      !! 
     1790      !! ** Action  : Get initial date in double precision YYYYMMDD.HHMMSS format 
    14441791      !! 
    14451792      !! History : 
    … …  
    14521799      USE phycst, ONLY : &            ! Physical constants 
    14531800         & rday 
    1454 !      USE daymod, ONLY : &            ! Time variables 
    1455 !         & nmonth_len            
    14561801      USE dom_oce, ONLY : &           ! Ocean space and time domain variables 
    14571802         & rdt 
    … …  
    14601805 
    14611806      !! * Arguments 
    1462       REAL(KIND=dp), INTENT(OUT) :: ddobsini                         ! Initial date in YYYYMMDD.HHMMSS 
     1807      REAL(dp), INTENT(OUT) :: ddobsini  ! Initial date in YYYYMMDD.HHMMSS 
    14631808 
    14641809      !! * Local declarations 
    … …  
    14681813      INTEGER :: ihou 
    14691814      INTEGER :: imin 
    1470       INTEGER :: imday         ! Number of days in month. 
    1471       REAL(KIND=wp) :: zdayfrc ! Fraction of day 
    1472  
    1473       INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year 
    1474  
    1475       !!---------------------------------------------------------------------- 
    1476       !! Initial date initialization (year, month, day, hour, minute) 
    1477       !! (This assumes that the initial date is for 00z)) 
    1478       !!---------------------------------------------------------------------- 
     1815      INTEGER :: imday       ! Number of days in month. 
     1816      INTEGER, DIMENSION(12) :: & 
     1817         &       imonth_len  ! Length in days of the months of the current year 
     1818      REAL(wp) :: zdayfrc    ! Fraction of day 
     1819 
     1820      !---------------------------------------------------------------------- 
     1821      ! Initial date initialization (year, month, day, hour, minute) 
     1822      ! (This assumes that the initial date is for 00z)) 
     1823      !---------------------------------------------------------------------- 
    14791824      iyea =   ndate0 / 10000 
    14801825      imon = ( ndate0 - iyea * 10000 ) / 100 
    … …  
    14831828      imin = 0 
    14841829 
    1485       !!---------------------------------------------------------------------- 
    1486       !! Compute number of days + number of hours + min since initial time 
    1487       !!---------------------------------------------------------------------- 
     1830      !---------------------------------------------------------------------- 
     1831      ! Compute number of days + number of hours + min since initial time 
     1832      !---------------------------------------------------------------------- 
    14881833      iday = iday + ( nit000 -1 ) * rdt / rday 
    14891834      zdayfrc = ( nit000 -1 ) * rdt / rday 
    … …  
    14921837      imin = int( (zdayfrc * 24 - ihou) * 60 ) 
    14931838 
    1494       !!----------------------------------------------------------------------- 
    1495       !! Convert number of days (iday) into a real date 
    1496       !!---------------------------------------------------------------------- 
     1839      !----------------------------------------------------------------------- 
     1840      ! Convert number of days (iday) into a real date 
     1841      !---------------------------------------------------------------------- 
    14971842 
    14981843      CALL calc_month_len( iyea, imonth_len ) 
    1499        
     1844 
    15001845      DO WHILE ( iday > imonth_len(imon) ) 
    15011846         iday = iday - imonth_len(imon) 
    … …  
    15081853      END DO 
    15091854 
    1510       !!---------------------------------------------------------------------- 
    1511       !! Convert it into YYYYMMDD.HHMMSS format. 
    1512       !!---------------------------------------------------------------------- 
     1855      !---------------------------------------------------------------------- 
     1856      ! Convert it into YYYYMMDD.HHMMSS format. 
     1857      !---------------------------------------------------------------------- 
    15131858      ddobsini = iyea * 10000_dp + imon * 100_dp + & 
    15141859         &       iday + ihou * 0.01_dp + imin * 0.0001_dp 
    … …  
    15201865      !!---------------------------------------------------------------------- 
    15211866      !!                    ***  ROUTINE fin_date  *** 
    1522       !!           
    1523       !! ** Purpose : Get final data in double precision YYYYMMDD.HHMMSS format 
    15241867      !! 
    1525       !! ** Method  : Get final data in double precision YYYYMMDD.HHMMSS format 
     1868      !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format 
    15261869      !! 
    1527       !! ** Action  : Get final data in double precision YYYYMMDD.HHMMSS format 
     1870      !! ** Method  : Get final date in double precision YYYYMMDD.HHMMSS format 
     1871      !! 
     1872      !! ** Action  : Get final date in double precision YYYYMMDD.HHMMSS format 
    15281873      !! 
    15291874      !! History : 
    … …  
    15351880      USE phycst, ONLY : &            ! Physical constants 
    15361881         & rday 
    1537 !      USE daymod, ONLY : &            ! Time variables 
    1538 !         & nmonth_len                 
    15391882      USE dom_oce, ONLY : &           ! Ocean space and time domain variables 
    15401883         & rdt 
    … …  
    15431886 
    15441887      !! * Arguments 
    1545       REAL(KIND=dp), INTENT(OUT) :: ddobsfin                  ! Final date in YYYYMMDD.HHMMSS 
     1888      REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS 
    15461889 
    15471890      !! * Local declarations 
    … …  
    15511894      INTEGER :: ihou 
    15521895      INTEGER :: imin 
    1553       INTEGER :: imday         ! Number of days in month. 
    1554       REAL(KIND=wp) :: zdayfrc       ! Fraction of day 
    1555           
    1556       INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year 
    1557              
     1896      INTEGER :: imday       ! Number of days in month. 
     1897      INTEGER, DIMENSION(12) :: & 
     1898         &       imonth_len  ! Length in days of the months of the current year 
     1899      REAL(wp) :: zdayfrc    ! Fraction of day 
     1900 
    15581901      !----------------------------------------------------------------------- 
    15591902      ! Initial date initialization (year, month, day, hour, minute) 
    … …  
    15651908      ihou = 0 
    15661909      imin = 0 
    1567        
     1910 
    15681911      !----------------------------------------------------------------------- 
    15691912      ! Compute number of days + number of hours + min since initial time 
    … …  
    15801923 
    15811924      CALL calc_month_len( iyea, imonth_len ) 
    1582        
     1925 
    15831926      DO WHILE ( iday > imonth_len(imon) ) 
    15841927         iday = iday - imonth_len(imon) 
    … …  
    15981941 
    15991942    END SUBROUTINE fin_date 
    1600      
     1943 
     1944    SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, ifiles, cobstypes, cfiles ) 
     1945 
     1946       INTEGER, INTENT(IN) :: ntypes      ! Total number of obs types 
     1947       INTEGER, INTENT(IN) :: jpmaxnfiles ! Maximum number of files allowed for each type 
     1948       INTEGER, DIMENSION(ntypes), INTENT(OUT) :: & 
     1949          &                   ifiles      ! Out number of files for each type 
     1950       CHARACTER(len=8), DIMENSION(ntypes), INTENT(IN) :: & 
     1951          &                   cobstypes   ! List of obs types 
     1952       CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(IN) :: & 
     1953          &                   cfiles      ! List of files for all types 
     1954 
     1955       !Local variables 
     1956       INTEGER :: jfile 
     1957       INTEGER :: jtype 
     1958 
     1959       DO jtype = 1, ntypes 
     1960 
     1961          ifiles(jtype) = 0 
     1962          DO jfile = 1, jpmaxnfiles 
     1963             IF ( trim(cfiles(jtype,jfile)) /= '' ) & 
     1964                       ifiles(jtype) = ifiles(jtype) + 1 
     1965          END DO 
     1966 
     1967          IF ( ifiles(jtype) == 0 ) THEN 
     1968               CALL ctl_stop( 'Logical for observation type '//TRIM(cobstypes(jtype))//   & 
     1969                  &           ' set to true but no files available to read' ) 
     1970          ENDIF 
     1971 
     1972          IF(lwp) THEN     
     1973             WRITE(numout,*) '             '//cobstypes(jtype)//' input observation file names:' 
     1974             DO jfile = 1, ifiles(jtype) 
     1975                WRITE(numout,*) '                '//TRIM(cfiles(jtype,jfile)) 
     1976             END DO 
     1977          ENDIF 
     1978 
     1979       END DO 
     1980 
     1981    END SUBROUTINE obs_settypefiles 
     1982 
     1983    SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein,             & 
     1984               &                  n2dint_default, n2dint_type,        & 
     1985               &                  ravglamscl_type, ravgphiscl_type,   & 
     1986               &                  lfp_indegs_type, lavnight_type,     & 
     1987               &                  n2dint, ravglamscl, ravgphiscl,     & 
     1988               &                  lfpindegs, lavnight ) 
     1989 
     1990       INTEGER, INTENT(IN)  :: ntypes             ! Total number of obs types 
     1991       INTEGER, INTENT(IN)  :: jtype              ! Index of the current type of obs 
     1992       INTEGER, INTENT(IN)  :: n2dint_default     ! Default option for interpolation type 
     1993       INTEGER, INTENT(IN)  :: n2dint_type        ! Option for interpolation type 
     1994       REAL(wp), INTENT(IN) :: & 
     1995          &                    ravglamscl_type, & !E/W diameter of obs footprint for this type 
     1996          &                    ravgphiscl_type    !N/S diameter of obs footprint for this type 
     1997       LOGICAL, INTENT(IN)  :: lfp_indegs_type    !T=> footprint in degrees, F=> in metres 
     1998       LOGICAL, INTENT(IN)  :: lavnight_type      !T=> obs represent night time average 
     1999       CHARACTER(len=8), INTENT(IN) :: ctypein  
     2000 
     2001       INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & 
     2002          &                    n2dint  
     2003       REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & 
     2004          &                    ravglamscl, ravgphiscl 
     2005       LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & 
     2006          &                    lfpindegs, lavnight 
     2007 
     2008       lavnight(jtype) = lavnight_type 
     2009 
     2010       IF ( (n2dint_type >= 0) .AND. (n2dint_type <= 6) ) THEN 
     2011          n2dint(jtype) = n2dint_type 
     2012       ELSE IF ( n2dint_type == -1 ) THEN 
     2013          n2dint(jtype) = n2dint_default 
     2014       ELSE 
     2015          CALL ctl_stop(' Choice of '//TRIM(ctypein)//' horizontal (2D) interpolation method', & 
     2016            &                    ' is not available') 
     2017       ENDIF 
     2018 
     2019       ! For averaging observation footprints set options for size of footprint  
     2020       IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN 
     2021          IF ( ravglamscl_type > 0._wp ) THEN 
     2022             ravglamscl(jtype) = ravglamscl_type 
     2023          ELSE 
     2024             CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 
     2025                            'scale (ravglamscl) for observation type '//TRIM(ctypein) )       
     2026          ENDIF 
     2027 
     2028          IF ( ravgphiscl_type > 0._wp ) THEN 
     2029             ravgphiscl(jtype) = ravgphiscl_type 
     2030          ELSE 
     2031             CALL ctl_stop( 'Incorrect value set for averaging footprint '// & 
     2032                            'scale (ravgphiscl) for observation type '//TRIM(ctypein) )       
     2033          ENDIF 
     2034 
     2035          lfpindegs(jtype) = lfp_indegs_type  
     2036 
     2037       ENDIF 
     2038 
     2039       ! Write out info  
     2040       IF(lwp) THEN 
     2041          IF ( n2dint(jtype) <= 4 ) THEN 
     2042             WRITE(numout,*) '             '//TRIM(ctypein)// & 
     2043                &            ' model counterparts will be interpolated horizontally' 
     2044          ELSE IF ( n2dint(jtype) <= 6 ) THEN 
     2045             WRITE(numout,*) '             '//TRIM(ctypein)// & 
     2046                &            ' model counterparts will be averaged horizontally' 
     2047             WRITE(numout,*) '             '//'    with E/W scale: ',ravglamscl(jtype) 
     2048             WRITE(numout,*) '             '//'    with N/S scale: ',ravgphiscl(jtype) 
     2049             IF ( lfpindegs(jtype) ) THEN 
     2050                 WRITE(numout,*) '             '//'    (in degrees)' 
     2051             ELSE 
     2052                 WRITE(numout,*) '             '//'    (in metres)' 
     2053             ENDIF 
     2054          ENDIF 
     2055       ENDIF 
     2056 
     2057    END SUBROUTINE obs_setinterpopts 
     2058 
    16012059END MODULE diaobs 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grd_bruteforce.h90

    r2358 r15670  
    325325         CALL obs_mpp_max_integer( kobsj, kobs ) 
    326326      ELSE 
    327          CALL obs_mpp_find_obs_proc( kproc, kobsi, kobsj, kobs ) 
     327         CALL obs_mpp_find_obs_proc( kproc,kobs ) 
    328328      ENDIF 
    329329 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grid.F90

    r8058 r15670  
    5252 
    5353   !! Default values 
    54    REAL, PUBLIC :: grid_search_res = 0.5    ! Resolution of grid 
     54   REAL, PUBLIC :: rn_gridsearchres = 0.5   ! Resolution of grid 
    5555   INTEGER, PRIVATE :: gsearch_nlons_def    ! Num of longitudes 
    5656   INTEGER, PRIVATE :: gsearch_nlats_def    ! Num of latitudes 
    … …  
    8383   LOGICAL, PUBLIC :: ln_grid_global         ! Use global distribution of observations 
    8484   CHARACTER(LEN=44), PUBLIC :: & 
    85       & grid_search_file    ! file name head for grid search lookup  
     85      & cn_gridsearchfile    ! file name head for grid search lookup  
    8686 
    8787   !!---------------------------------------------------------------------- 
    … …  
    613613         CALL obs_mpp_max_integer( kobsj, kobs ) 
    614614      ELSE 
    615          CALL obs_mpp_find_obs_proc( kproc, kobsi, kobsj, kobs ) 
     615         CALL obs_mpp_find_obs_proc( kproc, kobs ) 
    616616      ENDIF 
    617617 
    … …  
    690690          
    691691         IF(lwp) WRITE(numout,*) 
    692          IF(lwp) WRITE(numout,*)'Grid search resolution : ', grid_search_res 
    693           
    694          gsearch_nlons_def  = NINT( 360.0_wp / grid_search_res )  
    695          gsearch_nlats_def  = NINT( 180.0_wp / grid_search_res ) 
    696          gsearch_lonmin_def = -180.0_wp + 0.5_wp * grid_search_res 
    697          gsearch_latmin_def =  -90.0_wp + 0.5_wp * grid_search_res 
    698          gsearch_dlon_def   = grid_search_res 
    699          gsearch_dlat_def   = grid_search_res 
     692         IF(lwp) WRITE(numout,*)'Grid search resolution : ', rn_gridsearchres 
     693          
     694         gsearch_nlons_def  = NINT( 360.0_wp / rn_gridsearchres )  
     695         gsearch_nlats_def  = NINT( 180.0_wp / rn_gridsearchres ) 
     696         gsearch_lonmin_def = -180.0_wp + 0.5_wp * rn_gridsearchres 
     697         gsearch_latmin_def =  -90.0_wp + 0.5_wp * rn_gridsearchres 
     698         gsearch_dlon_def   = rn_gridsearchres 
     699         gsearch_dlat_def   = rn_gridsearchres 
    700700          
    701701         IF (lwp) THEN 
    … …  
    710710         IF ( ln_grid_global ) THEN 
    711711            WRITE(cfname, FMT="(A,'_',A)") & 
    712                &          TRIM(grid_search_file), 'global.nc' 
     712               &          TRIM(cn_gridsearchfile), 'global.nc' 
    713713         ELSE 
    714714            WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") & 
    715                &          TRIM(grid_search_file), nproc, jpni, jpnj 
     715               &          TRIM(cn_gridsearchfile), nproc, jpni, jpnj 
    716716         ENDIF 
    717717 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_inter_sup.F90

    r8058 r15670  
    3535CONTAINS 
    3636 
    37    SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpk, kgrdi, kgrdj, & 
     37   SUBROUTINE obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 
    3838      &                        pval, pgval, kproc ) 
    3939      !!---------------------------------------------------------------------- 
    … …  
    5757      INTEGER, INTENT(IN) :: kptsj     ! Number of j horizontal points per stencil 
    5858      INTEGER, INTENT(IN) :: kobs      ! Local number of observations 
     59      INTEGER, INTENT(IN) :: kpi       ! Number of points in i direction 
     60      INTEGER, INTENT(IN) :: kpj       ! Number of points in j direction 
    5961      INTEGER, INTENT(IN) :: kpk       ! Number of levels 
    6062      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    … …  
    6365      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    6466         & kproc            ! Precomputed processor for each i,j,iobs points 
    65       REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
     67      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 
    6668         & pval             ! Local 3D array to extract data from 
    6769      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
    … …  
    7375         IF (PRESENT(kproc)) THEN 
    7476 
    75             CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpk, kgrdi, & 
     77            CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & 
    7678               &                         kgrdj, pval, pgval, kproc=kproc ) 
    7779 
    7880         ELSE 
    7981 
    80             CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpk, kgrdi, & 
     82            CALL obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, & 
    8183               &                         kgrdj, pval, pgval ) 
    8284 
    … …  
    8587      ELSE 
    8688 
    87          CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpk, kgrdi, kgrdj, & 
     89         CALL obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 
    8890            &                        pval, pgval ) 
    8991 
    … …  
    9294   END SUBROUTINE obs_int_comm_3d 
    9395 
    94    SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kgrdi, kgrdj, pval, pgval, & 
     96   SUBROUTINE obs_int_comm_2d( kptsi, kptsj, kobs, kpi, kpj, kgrdi, kgrdj, pval, pgval, & 
    9597      &                        kproc ) 
    9698      !!---------------------------------------------------------------------- 
    … …  
    111113      INTEGER, INTENT(IN) :: kptsj        ! Number of j horizontal points per stencil 
    112114      INTEGER, INTENT(IN) :: kobs          ! Local number of observations 
     115      INTEGER, INTENT(IN) :: kpi          ! Number of model grid points in i direction 
     116      INTEGER, INTENT(IN) :: kpj          ! Number of model grid points in j direction 
    113117      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    114118         & kgrdi, &         ! i,j indicies for each stencil 
    … …  
    116120      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    117121         & kproc            ! Precomputed processor for each i,j,iobs points 
    118       REAL(KIND=wp), DIMENSION(jpi,jpj), INTENT(IN) ::& 
     122      REAL(KIND=wp), DIMENSION(kpi,kpj), INTENT(IN) ::& 
    119123         & pval             ! Local 3D array to extra data from 
    120124      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kobs), INTENT(OUT) ::& 
    … …  
    136140      IF (PRESENT(kproc)) THEN 
    137141 
    138          CALL obs_int_comm_3d( kptsi, kptsj, kobs, 1, kgrdi, kgrdj, zval, & 
     142         CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & 
    139143            &                  zgval, kproc=kproc ) 
    140144      ELSE 
    141145 
    142          CALL obs_int_comm_3d( kptsi, kptsj, kobs, 1, kgrdi, kgrdj, zval, & 
     146         CALL obs_int_comm_3d( kptsi, kptsj, kobs, kpi, kpj, 1, kgrdi, kgrdj, zval, & 
    143147            &                  zgval ) 
    144148 
    … …  
    154158   END SUBROUTINE obs_int_comm_2d 
    155159 
    156    SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpk, kgrdi, kgrdj, & 
     160   SUBROUTINE obs_int_comm_3d_global( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 
    157161      &                               pval, pgval, kproc ) 
    158162      !!---------------------------------------------------------------------- 
    … …  
    174178      INTEGER, INTENT(IN) :: kptsj     ! Number of j horizontal points per stencil 
    175179      INTEGER, INTENT(IN) :: kobs      ! Local number of observations 
     180      INTEGER, INTENT(IN) :: kpi       ! Number of model points in i direction 
     181      INTEGER, INTENT(IN) :: kpj       ! Number of model points in j direction 
    176182      INTEGER, INTENT(IN) :: kpk       ! Number of levels 
    177183      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    … …  
    180186      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    181187         & kproc            ! Precomputed processor for each i,j,iobs points 
    182       REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
     188      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 
    183189         & pval             ! Local 3D array to extract data from 
    184190      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
    … …  
    207213 
    208214      ! Check valid points 
    209        
     215 
    210216      IF ( ( MAXVAL(kgrdi) > jpiglo ) .OR. ( MINVAL(kgrdi) < 1 ) .OR. & 
    211217         & ( MAXVAL(kgrdj) > jpjglo ) .OR. ( MINVAL(kgrdj) < 1 ) ) THEN 
    212           
     218 
    213219         CALL ctl_stop( 'Error in obs_int_comm_3d_global', & 
    214220            &           'Point outside global domain' ) 
    215           
     221 
    216222      ENDIF 
    217223 
    … …  
    323329   END SUBROUTINE obs_int_comm_3d_global 
    324330    
    325    SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpk, kgrdi, kgrdj, & 
     331   SUBROUTINE obs_int_comm_3d_local( kptsi, kptsj, kobs, kpi, kpj, kpk, kgrdi, kgrdj, & 
    326332      &                              pval, pgval ) 
    327333      !!---------------------------------------------------------------------- 
    … …  
    343349      INTEGER, INTENT(IN) :: kptsj        ! Number of j horizontal points per stencil 
    344350      INTEGER, INTENT(IN) :: kobs         ! Local number of observations 
     351      INTEGER, INTENT(IN) :: kpi          ! Number of model points in i direction 
     352      INTEGER, INTENT(IN) :: kpj          ! Number of model points in j direction 
    345353      INTEGER, INTENT(IN) :: kpk          ! Number of levels 
    346354      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    347355         & kgrdi, &         ! i,j indicies for each stencil 
    348356         & kgrdj 
    349       REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
     357      REAL(KIND=wp), DIMENSION(kpi,kpj,kpk), INTENT(IN) ::& 
    350358         & pval             ! Local 3D array to extract data from 
    351359      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_level_search.h90

    r8058 r15670  
    1313      !! ** Method  : Straightforward search 
    1414      !! 
    15       !! ** Action  :  
     15      !! ** Action  : Will return level associated with T-point below the obs 
     16      !!              depth, except when observation is in the top box will  
     17      !!              return level 2. Also, if obs depth greater than depth  
     18      !!              of last wet T-point (kpk-1) will return level kpk. 
    1619      !! 
    1720      !! History : 
    … …  
    4346      DO ji = 1, kobs  
    4447         kobsk(ji) = 1 
    45          depk: DO jk = 2, kgrd 
    46             IF ( pgrddep(jk) >= pobsdep(ji) ) EXIT depk 
     48         depk: DO jk = 2, kgrd-1 
     49            IF ( pgrddep(jk) > pobsdep(ji) ) EXIT depk 
    4750         END DO depk 
    4851         kobsk(ji) = jk 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90

    r8058 r15670  
    77   !!             -   ! 2006-05  (K. Mogensen)  Reformatted 
    88   !!             -   ! 2008-01  (K. Mogensen)  add mpp_global_max 
     9   !!            3.6  ! 2015-01  (J. Waters) obs_mpp_find_obs_proc  
     10   !!                            rewritten to avoid global arrays 
    911   !!---------------------------------------------------------------------- 
    1012#  define mpivar mpi_double_precision 
    … …  
    1214   !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors 
    1315   !! obs_mpp_max_integer   : Find maximum on all processors of each value in an integer on all processors 
    14    !! obs_mpp_find_obs_proc : Find processors which should hold the observations 
     16   !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays 
    1517   !! obs_mpp_sum_integers  : Sum an integer array from all processors 
    1618   !! obs_mpp_sum_integer   : Sum an integer from all processors 
    … …  
    9698      ! 
    9799      INTEGER :: ierr  
    98       INTEGER, DIMENSION(kno) ::   ivals 
    99       ! 
    100 INCLUDE 'mpif.h' 
    101       !!---------------------------------------------------------------------- 
     100      INTEGER, DIMENSION(:), ALLOCATABLE ::   ivals 
     101      ! 
     102INCLUDE 'mpif.h' 
     103      !!---------------------------------------------------------------------- 
     104 
     105      ALLOCATE( ivals(kno) ) 
    102106 
    103107      ! Call the MPI library to find the maximum across processors 
    … …  
    105109         &                mpi_max, mpi_comm_opa, ierr ) 
    106110      kvals(:) = ivals(:) 
     111 
     112      DEALLOCATE( ivals ) 
    107113#else 
    108114      ! no MPI: empty routine 
    … …  
    111117 
    112118 
    113    SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj, kno ) 
    114       !!---------------------------------------------------------------------- 
    115       !!               ***  ROUTINE obs_mpp_find_obs_proc *** 
    116       !!           
    117       !! ** Purpose : From the array kobsp containing the results of the grid 
     119   SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) 
     120      !!---------------------------------------------------------------------- 
     121      !!               ***  ROUTINE obs_mpp_find_obs_proc  *** 
     122      !!          
     123      !! ** Purpose : From the array kobsp containing the results of the 
    118124      !!              grid search on each processor the processor return a 
    119125      !!              decision of which processors should hold the observation. 
    120126      !! 
    121       !! ** Method  : A temporary 2D array holding all the decisions is 
    122       !!              constructed using mpi_allgather on each processor. 
    123       !!              If more than one processor has found the observation 
    124       !!              with the observation in the inner domain gets it 
    125       !! 
    126       !! ** Action  : This does only work for MPI.  
     127      !! ** Method  : Synchronize the processor number for each obs using 
     128      !!              obs_mpp_max_integer. If an observation exists on two  
     129      !!              processors it will be allocated to the lower numbered 
     130      !!              processor. 
     131      !! 
     132      !! ** Action  : This does only work for MPI. 
    127133      !!              It does not work for SHMEM. 
    128134      !! 
    … …  
    130136      !!---------------------------------------------------------------------- 
    131137      INTEGER                , INTENT(in   ) ::   kno 
    132       INTEGER, DIMENSION(kno), INTENT(in   ) ::   kobsi, kobsj 
    133138      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp 
    134139      ! 
    135140#if defined key_mpp_mpi 
    136141      ! 
    137       INTEGER :: ji 
    138       INTEGER :: jj 
    139       INTEGER :: size 
    140       INTEGER :: ierr 
    141       INTEGER :: iobsip 
    142       INTEGER :: iobsjp 
    143       INTEGER :: num_sus_obs 
    144       INTEGER, DIMENSION(kno) ::   iobsig, iobsjg 
    145       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iobsp, iobsi, iobsj 
    146       !! 
    147 INCLUDE 'mpif.h' 
    148       !!---------------------------------------------------------------------- 
    149  
    150       !----------------------------------------------------------------------- 
    151       ! Call the MPI library to find the maximum accross processors 
    152       !----------------------------------------------------------------------- 
    153       CALL mpi_comm_size( mpi_comm_opa, size, ierr ) 
    154       !----------------------------------------------------------------------- 
    155       ! Convert local grids points to global grid points 
    156       !----------------------------------------------------------------------- 
     142      ! 
     143      INTEGER :: ji, isum 
     144      INTEGER, DIMENSION(:), ALLOCATABLE ::   iobsp 
     145      !! 
     146      !! 
     147 
     148      ALLOCATE( iobsp(kno) ) 
     149 
     150      iobsp(:)=kobsp(:) 
     151 
     152      WHERE( iobsp(:) == -1 ) 
     153         iobsp(:) = 9999999 
     154      END WHERE 
     155 
     156      iobsp(:)=-1*iobsp(:) 
     157 
     158      CALL obs_mpp_max_integer( iobsp, kno ) 
     159 
     160      kobsp(:)=-1*iobsp(:) 
     161 
     162      isum=0 
    157163      DO ji = 1, kno 
    158          IF ( ( kobsi(ji) >= 1 ) .AND. ( kobsi(ji) <= jpi ) .AND. & 
    159             & ( kobsj(ji) >= 1 ) .AND. ( kobsj(ji) <= jpj ) ) THEN 
    160             iobsig(ji) = mig( kobsi(ji) ) 
    161             iobsjg(ji) = mjg( kobsj(ji) ) 
    162          ELSE 
    163             iobsig(ji) = -1 
    164             iobsjg(ji) = -1 
     164         IF ( kobsp(ji) == 9999999 ) THEN 
     165            isum=isum+1 
     166            kobsp(ji)=-1 
    165167         ENDIF 
    166       END DO 
    167       !----------------------------------------------------------------------- 
    168       ! Get the decisions from all processors 
    169       !----------------------------------------------------------------------- 
    170       ALLOCATE( iobsp(kno,size) ) 
    171       ALLOCATE( iobsi(kno,size) ) 
    172       ALLOCATE( iobsj(kno,size) ) 
    173       CALL mpi_allgather( kobsp, kno, mpi_integer, & 
    174          &                iobsp, kno, mpi_integer, & 
    175          &                mpi_comm_opa, ierr ) 
    176       CALL mpi_allgather( iobsig, kno, mpi_integer, & 
    177          &                iobsi, kno, mpi_integer, & 
    178          &                mpi_comm_opa, ierr ) 
    179       CALL mpi_allgather( iobsjg, kno, mpi_integer, & 
    180          &                iobsj, kno, mpi_integer, & 
    181          &                mpi_comm_opa, ierr ) 
    182  
    183       !----------------------------------------------------------------------- 
    184       ! Find the processor with observations from the lowest processor  
    185       ! number among processors holding the observation. 
    186       !----------------------------------------------------------------------- 
    187       kobsp(:) = -1 
    188       num_sus_obs = 0 
    189       DO ji = 1, kno 
    190          DO jj = 1, size 
    191             IF ( ( kobsp(ji) == -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN 
    192                kobsp(ji) = iobsp(ji,jj) 
    193                iobsip = iobsi(ji,jj) 
    194                iobsjp = iobsj(ji,jj) 
    195             ENDIF 
    196             IF ( ( kobsp(ji) /= -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN 
    197                IF ( ( iobsip /= iobsi(ji,jj) ) .OR. & 
    198                   & ( iobsjp /= iobsj(ji,jj) ) ) THEN 
    199                   IF ( ( kobsp(ji) < 1000000 ) .AND. & 
    200                      & ( iobsp(ji,jj) < 1000000 ) ) THEN 
    201                      num_sus_obs=num_sus_obs+1 
    202                   ENDIF 
    203                ENDIF 
    204                IF ( mppmap(iobsip,iobsjp) /= ( kobsp(ji)+1 ) ) THEN 
    205                   IF ( ( iobsi(ji,jj) /= -1 ) .AND. & 
    206                      & ( iobsj(ji,jj) /= -1 ) ) THEN 
    207                      IF ((mppmap(iobsi(ji,jj),iobsj(ji,jj)) == (iobsp(ji,jj)+1))& 
    208                         & .OR. ( iobsp(ji,jj) < kobsp(ji) ) ) THEN 
    209                         kobsp(ji) = iobsp(ji,jj) 
    210                         iobsip = iobsi(ji,jj) 
    211                         iobsjp = iobsj(ji,jj) 
    212                      ENDIF 
    213                   ENDIF 
    214                ENDIF 
    215             ENDIF 
    216          END DO 
    217       END DO 
    218       IF (lwp) WRITE(numout,*) 'Number of suspicious observations: ',num_sus_obs 
    219  
    220       DEALLOCATE( iobsj ) 
    221       DEALLOCATE( iobsi ) 
     168      ENDDO 
     169 
     170 
     171      IF ( isum > 0 ) THEN 
     172         IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' 
     173         IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' 
     174      ENDIF 
     175 
    222176      DEALLOCATE( iobsp ) 
     177 
    223178#else 
    224179      ! no MPI: empty routine 
    225 #endif 
    226       ! 
     180#endif      
     181       
    227182   END SUBROUTINE obs_mpp_find_obs_proc 
    228183 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_oper.F90

    r8058 r15670  
    77 
    88   !!---------------------------------------------------------------------- 
    9    !!   obs_pro_opt :    Compute the model counterpart of temperature and 
    10    !!                    salinity observations from profiles 
    11    !!   obs_sla_opt :    Compute the model counterpart of sea level anomaly 
    12    !!                    observations 
    13    !!   obs_sst_opt :    Compute the model counterpart of sea surface temperature 
    14    !!                    observations 
    15    !!   obs_sss_opt :    Compute the model counterpart of sea surface salinity 
    16    !!                    observations 
    17    !!   obs_seaice_opt : Compute the model counterpart of sea ice concentration 
    18    !!                    observations 
    19    !! 
    20    !!   obs_vel_opt :    Compute the model counterpart of zonal and meridional 
    21    !!                    components of velocity from observations. 
     9   !!   obs_prof_opt :    Compute the model counterpart of profile data 
     10   !!   obs_surf_opt :    Compute the model counterpart of surface data 
    2211   !!---------------------------------------------------------------------- 
    2312 
    24    !! * Modules used    
     13   !! * Modules used 
    2514   USE par_kind, ONLY : &         ! Precision variables 
    2615      & wp 
    2716   USE in_out_manager             ! I/O manager 
    2817   USE obs_inter_sup              ! Interpolation support 
    29    USE obs_inter_h2d, ONLY : &    ! Horizontal interpolation to the observation pt 
     18   USE obs_inter_h2d, ONLY : &    ! Horizontal interpolation to the obs pt 
    3019      & obs_int_h2d, & 
    3120      & obs_int_h2d_init 
    32    USE obs_inter_z1d, ONLY : &    ! Vertical interpolation to the observation pt 
     21   USE obs_averg_h2d, ONLY : &    ! Horizontal averaging to the obs footprint 
     22      & obs_avg_h2d, & 
     23      & obs_avg_h2d_init, & 
     24      & obs_max_fpsize 
     25   USE obs_inter_z1d, ONLY : &    ! Vertical interpolation to the obs pt 
    3326      & obs_int_z1d,    & 
    3427      & obs_int_z1d_spl 
    35    USE obs_const,  ONLY :     & 
    36       & obfillflt      ! Fillvalue    
     28   USE obs_const,  ONLY :    &    ! Obs fill value 
     29      & obfillflt 
    3730   USE dom_oce,       ONLY : & 
    38       & glamt, glamu, glamv, & 
    39       & gphit, gphiu, gphiv 
    40    USE lib_mpp,       ONLY : & 
     31      & glamt, glamf, & 
     32      & gphit, gphif 
     33   USE lib_mpp,       ONLY : &    ! Warning and stopping routines 
    4134      & ctl_warn, ctl_stop 
     35   USE sbcdcy,        ONLY : &    ! For calculation of where it is night-time 
     36      & sbc_dcy, nday_qsr 
     37   USE obs_grid,      ONLY : &  
     38      & obs_level_search      
    4239 
    4340   IMPLICIT NONE 
    … …  
    4643   PRIVATE 
    4744 
    48    PUBLIC obs_pro_opt, &  ! Compute the model counterpart of profile observations 
    49       &   obs_sla_opt, &  ! Compute the model counterpart of SLA observations 
    50       &   obs_sst_opt, &  ! Compute the model counterpart of SST observations 
    51       &   obs_sss_opt, &  ! Compute the model counterpart of SSS observations 
    52       &   obs_seaice_opt, & 
    53       &   obs_vel_opt     ! Compute the model counterpart of velocity profile data 
    54  
    55    INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 ! Max number of daily avgd obs types 
     45   PUBLIC obs_prof_opt, &  ! Compute the model counterpart of profile obs 
     46      &   obs_surf_opt     ! Compute the model counterpart of surface obs 
     47 
     48   INTEGER, PARAMETER, PUBLIC :: & 
     49      & imaxavtypes = 20   ! Max number of daily avgd obs types 
    5650 
    5751   !!---------------------------------------------------------------------- 
    … …  
    6155   !!---------------------------------------------------------------------- 
    6256 
     57   !! * Substitutions  
     58#  include "domzgr_substitute.h90"  
    6359CONTAINS 
    6460 
    65    SUBROUTINE obs_pro_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 
    66       &                    ptn, psn, pgdept, ptmask, k1dint, k2dint, & 
    67       &                    kdailyavtypes ) 
     61 
     62   SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & 
     63      &                     kit000, kdaystp, kvar,       & 
     64      &                     pvar, pclim,                 & 
     65      &                     pgdept, pgdepw, pmask,       &   
     66      &                     plam, pphi,                  & 
     67      &                     k1dint, k2dint, kdailyavtypes ) 
     68 
    6869      !!----------------------------------------------------------------------- 
    6970      !! 
    … …  
    7879      !! 
    7980      !!    First, a vertical profile of horizontally interpolated model 
    80       !!    now temperatures is computed at the obs (lon, lat) point. 
     81      !!    now values is computed at the obs (lon, lat) point. 
    8182      !!    Several horizontal interpolation schemes are available: 
    8283      !!        - distance-weighted (great circle) (k2dint = 0) 
    … …  
    8687      !!        - polynomial (quadrilateral grid)  (k2dint = 4) 
    8788      !! 
    88       !!    Next, the vertical temperature profile is interpolated to the 
     89      !!    Next, the vertical profile is interpolated to the 
    8990      !!    data depth points. Two vertical interpolation schemes are 
    9091      !!    available: 
    … …  
    9697      !!    routine. 
    9798      !! 
    98       !!    For ENACT moored buoy data (e.g., TAO), the model equivalent is 
     99      !!    If the logical is switched on, the model equivalent is 
    99100      !!    a daily mean model temperature field. So, we first compute 
    100101      !!    the mean, then interpolate only at the end of the day. 
    101102      !! 
    102       !!    Note: the in situ temperature observations must be converted 
     103      !!    Note: in situ temperature observations must be converted 
    103104      !!    to potential temperature (the model variable) prior to 
    104105      !!    assimilation.  
    105       !!?????????????????????????????????????????????????????????????? 
    106       !!    INCLUDE POTENTIAL TEMP -> IN SITU TEMP IN OBS OPERATOR??? 
    107       !!?????????????????????????????????????????????????????????????? 
    108106      !! 
    109107      !! ** Action  : 
    … …  
    115113      !!      ! 07-01 (K. Mogensen) Merge of temperature and salinity 
    116114      !!      ! 07-03 (K. Mogensen) General handling of profiles 
     115      !!      ! 15-02 (M. Martin) Combined routine for all profile types 
     116      !!      ! 17-02 (M. Martin) Include generalised vertical coordinate changes 
    117117      !!----------------------------------------------------------------------- 
    118    
     118 
    119119      !! * Modules used 
    120120      USE obs_profiles_def ! Definition of storage space for profile obs. 
    … …  
    123123 
    124124      !! * Arguments 
    125       TYPE(obs_prof), INTENT(INOUT) :: prodatqc  ! Subset of profile data not failing screening 
    126       INTEGER, INTENT(IN) :: kt        ! Time step 
    127       INTEGER, INTENT(IN) :: kpi       ! Model grid parameters 
     125      TYPE(obs_prof), INTENT(INOUT) :: & 
     126         & prodatqc                  ! Subset of profile data passing QC 
     127      INTEGER, INTENT(IN) :: kt      ! Time step 
     128      INTEGER, INTENT(IN) :: kpi     ! Model grid parameters 
    128129      INTEGER, INTENT(IN) :: kpj 
    129130      INTEGER, INTENT(IN) :: kpk 
    130       INTEGER, INTENT(IN) :: kit000    ! Number of the first time step  
    131                                        !   (kit000-1 = restart time) 
    132       INTEGER, INTENT(IN) :: k1dint    ! Vertical interpolation type (see header) 
    133       INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
    134       INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day                     
     131      INTEGER, INTENT(IN) :: kit000  ! Number of the first time step 
     132                                     !   (kit000-1 = restart time) 
     133      INTEGER, INTENT(IN) :: k1dint  ! Vertical interpolation type (see header) 
     134      INTEGER, INTENT(IN) :: k2dint  ! Horizontal interpolation type (see header) 
     135      INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 
     136      INTEGER, INTENT(IN) :: kvar    ! Number of variable in prodatqc 
    135137      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    136          & ptn,    &    ! Model temperature field 
    137          & psn,    &    ! Model salinity field 
    138          & ptmask       ! Land-sea mask 
    139       REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 
    140          & pgdept       ! Model array of depth levels 
     138         & pvar,   &                 ! Model field for variable 
     139         & pclim,  &                 ! Climatology field for variable          
     140         & pmask                     ! Land-sea mask for variable 
     141      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
     142         & plam,   &                 ! Model longitudes for variable 
     143         & pphi                      ! Model latitudes for variable 
     144      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: &  
     145         & pgdept, &                 ! Model array of depth T levels  
     146         & pgdepw                    ! Model array of depth W levels  
    141147      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    142          & kdailyavtypes! Types for daily averages 
     148         & kdailyavtypes             ! Types for daily averages 
     149 
    143150      !! * Local declarations 
    144151      INTEGER ::   ji 
    … …  
    152159      INTEGER ::   iend 
    153160      INTEGER ::   iobs 
     161      INTEGER ::   iin, ijn, ikn, ik   ! looping indices over interpolation nodes  
     162      INTEGER ::   inum_obs 
    154163      INTEGER, DIMENSION(imaxavtypes) :: & 
    155164         & idailyavtypes 
     165      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
     166         & igrdi, & 
     167         & igrdj 
     168      INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic 
     169 
    156170      REAL(KIND=wp) :: zlam 
    157171      REAL(KIND=wp) :: zphi 
    158172      REAL(KIND=wp) :: zdaystp 
    159173      REAL(KIND=wp), DIMENSION(kpk) :: & 
    160          & zobsmask, & 
    161174         & zobsk,    & 
    162          & zobs2k 
    163       REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 
     175         & zobs2k,   & 
     176         & zclm2k          
     177      REAL(KIND=wp), DIMENSION(2,2,1) :: & 
     178         & zweig1, & 
    164179         & zweig 
    165180      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
    166          & zmask, & 
    167          & zintt, & 
    168          & zints, & 
    169          & zinmt, & 
    170          & zinms 
     181         & zmask,  & 
     182         & zclim,  &          
     183         & zint,   & 
     184         & zinm,   & 
     185         & zgdept, &  
     186         & zgdepw 
    171187      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    172          & zglam, & 
     188         & zglam,  & 
    173189         & zgphi 
    174       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    175          & igrdi, & 
    176          & igrdj 
     190      REAL(KIND=wp), DIMENSION(1) :: zmsk 
     191      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner 
     192      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner_clim 
     193       
     194      LOGICAL :: ld_dailyav 
    177195 
    178196      !------------------------------------------------------------------------ 
    179197      ! Local initialization  
    180198      !------------------------------------------------------------------------ 
    181       ! ... Record and data counters 
     199      ! Record and data counters 
    182200      inrc = kt - kit000 + 2 
    183201      ipro = prodatqc%npstp(inrc) 
    184   
     202 
    185203      ! Daily average types 
     204      ld_dailyav = .FALSE. 
    186205      IF ( PRESENT(kdailyavtypes) ) THEN 
    187206         idailyavtypes(:) = kdailyavtypes(:) 
     207         IF ( ANY (idailyavtypes(:) /= -1) ) ld_dailyav = .TRUE. 
    188208      ELSE 
    189209         idailyavtypes(:) = -1 
    190210      ENDIF 
    191211 
    192       ! Initialize daily mean for first timestep 
     212      ! Daily means are calculated for values over timesteps: 
     213      !  [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ... 
    193214      idayend = MOD( kt - kit000 + 1, kdaystp ) 
    194215 
    195       ! Added kt == 0 test to catch restart case  
    196       IF ( idayend == 1 .OR. kt == 0) THEN 
    197          IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 
     216      IF ( ld_dailyav ) THEN 
     217 
     218         ! Initialize daily mean for first timestep of the day 
     219         IF ( idayend == 1 .OR. kt == 0 ) THEN 
     220            DO jk = 1, jpk 
     221               DO jj = 1, jpj 
     222                  DO ji = 1, jpi 
     223                     prodatqc%vdmean(ji,jj,jk,kvar) = 0.0 
     224                  END DO 
     225               END DO 
     226            END DO 
     227         ENDIF 
     228 
    198229         DO jk = 1, jpk 
    199230            DO jj = 1, jpj 
    200231               DO ji = 1, jpi 
    201                   prodatqc%vdmean(ji,jj,jk,1) = 0.0 
    202                   prodatqc%vdmean(ji,jj,jk,2) = 0.0 
     232                  ! Increment field for computing daily mean 
     233                  prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 
     234                     &                           + pvar(ji,jj,jk) 
    203235               END DO 
    204236            END DO 
    205237         END DO 
    206       ENDIF 
    207  
    208       DO jk = 1, jpk 
    209          DO jj = 1, jpj 
    210             DO ji = 1, jpi 
    211                ! Increment the temperature field for computing daily mean 
    212                prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
    213                   &                        + ptn(ji,jj,jk) 
    214                ! Increment the salinity field for computing daily mean 
    215                prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
    216                   &                        + psn(ji,jj,jk) 
    217             END DO 
    218          END DO 
    219       END DO 
    220     
    221       ! Compute the daily mean at the end of day 
    222       zdaystp = 1.0 / REAL( kdaystp ) 
    223       IF ( idayend == 0 ) THEN 
    224          DO jk = 1, jpk 
    225             DO jj = 1, jpj 
    226                DO ji = 1, jpi 
    227                   prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
    228                      &                        * zdaystp 
    229                   prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
    230                   &                           * zdaystp 
     238 
     239         ! Compute the daily mean at the end of day 
     240         zdaystp = 1.0 / REAL( kdaystp ) 
     241         IF ( idayend == 0 ) THEN 
     242            IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt 
     243            CALL FLUSH(numout) 
     244            DO jk = 1, jpk 
     245               DO jj = 1, jpj 
     246                  DO ji = 1, jpi 
     247                     prodatqc%vdmean(ji,jj,jk,kvar) = prodatqc%vdmean(ji,jj,jk,kvar) & 
     248                        &                           * zdaystp 
     249                  END DO 
    231250               END DO 
    232251            END DO 
    233          END DO 
     252         ENDIF 
     253 
    234254      ENDIF 
    235255 
    236256      ! Get the data for interpolation 
    237257      ALLOCATE( & 
    238          & igrdi(2,2,ipro),      & 
    239          & igrdj(2,2,ipro),      & 
    240          & zglam(2,2,ipro),      & 
    241          & zgphi(2,2,ipro),      & 
    242          & zmask(2,2,kpk,ipro),  & 
    243          & zintt(2,2,kpk,ipro),  & 
    244          & zints(2,2,kpk,ipro)   & 
     258         & igrdi(2,2,ipro),       & 
     259         & igrdj(2,2,ipro),       & 
     260         & zglam(2,2,ipro),       & 
     261         & zgphi(2,2,ipro),       & 
     262         & zmask(2,2,kpk,ipro),   & 
     263         & zint(2,2,kpk,ipro),    & 
     264         & zgdept(2,2,kpk,ipro),  &  
     265         & zgdepw(2,2,kpk,ipro)   &  
    245266         & ) 
     267 
     268      IF ( prodatqc%lclim ) ALLOCATE( zclim(2,2,kpk,ipro) ) 
    246269 
    247270      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
    248271         iobs = jobs - prodatqc%nprofup 
    249          igrdi(1,1,iobs) = prodatqc%mi(jobs,1)-1 
    250          igrdj(1,1,iobs) = prodatqc%mj(jobs,1)-1 
    251          igrdi(1,2,iobs) = prodatqc%mi(jobs,1)-1 
    252          igrdj(1,2,iobs) = prodatqc%mj(jobs,1) 
    253          igrdi(2,1,iobs) = prodatqc%mi(jobs,1) 
    254          igrdj(2,1,iobs) = prodatqc%mj(jobs,1)-1 
    255          igrdi(2,2,iobs) = prodatqc%mi(jobs,1) 
    256          igrdj(2,2,iobs) = prodatqc%mj(jobs,1) 
     272         igrdi(1,1,iobs) = prodatqc%mi(jobs,kvar)-1 
     273         igrdj(1,1,iobs) = prodatqc%mj(jobs,kvar)-1 
     274         igrdi(1,2,iobs) = prodatqc%mi(jobs,kvar)-1 
     275         igrdj(1,2,iobs) = prodatqc%mj(jobs,kvar) 
     276         igrdi(2,1,iobs) = prodatqc%mi(jobs,kvar) 
     277         igrdj(2,1,iobs) = prodatqc%mj(jobs,kvar)-1 
     278         igrdi(2,2,iobs) = prodatqc%mi(jobs,kvar) 
     279         igrdj(2,2,iobs) = prodatqc%mj(jobs,kvar) 
    257280      END DO 
    258281 
    259       CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, glamt, zglam ) 
    260       CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, gphit, zgphi ) 
    261       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptmask,zmask ) 
    262       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptn,   zintt ) 
    263       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, psn,   zints ) 
    264  
     282      ! Initialise depth arrays 
     283      zgdept(:,:,:,:) = 0.0 
     284      zgdepw(:,:,:,:) = 0.0 
     285 
     286      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, plam, zglam ) 
     287      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 
     288      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pmask, zmask ) 
     289      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pvar,   zint ) 
     290 
     291      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept, zgdept )  
     292      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw, zgdepw )  
     293 
     294      IF ( prodatqc%lclim ) THEN 
     295         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pclim, zclim )             
     296      ENDIF  
     297       
    265298      ! At the end of the day also get interpolated means 
    266       IF ( idayend == 0 ) THEN 
    267  
    268          ALLOCATE( & 
    269             & zinmt(2,2,kpk,ipro),  & 
    270             & zinms(2,2,kpk,ipro)  & 
    271             & ) 
    272  
    273          CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, & 
    274             &                  prodatqc%vdmean(:,:,:,1), zinmt ) 
    275          CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, & 
    276             &                  prodatqc%vdmean(:,:,:,2), zinms ) 
    277  
    278       ENDIF 
     299      IF ( ld_dailyav .AND. idayend == 0 ) THEN 
     300 
     301         ALLOCATE( zinm(2,2,kpk,ipro) ) 
     302 
     303         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, & 
     304            &                  prodatqc%vdmean(:,:,:,kvar), zinm ) 
     305 
     306      ENDIF 
     307 
     308      ! Return if no observations to process  
     309      ! Has to be done after comm commands to ensure processors  
     310      ! stay in sync  
     311      IF ( ipro == 0 ) RETURN  
    279312 
    280313      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
    … …  
    283316 
    284317         IF ( kt /= prodatqc%mstp(jobs) ) THEN 
    285              
     318 
    286319            IF(lwp) THEN 
    287320               WRITE(numout,*) 
    … …  
    298331            CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 
    299332         ENDIF 
    300           
     333 
    301334         zlam = prodatqc%rlam(jobs) 
    302335         zphi = prodatqc%rphi(jobs) 
     336 
     337         ! Horizontal weights  
     338         ! Masked values are calculated later.   
     339         IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 
     340 
     341            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     & 
     342               &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
     343               &                   zmask(:,:,1,iobs), zweig1, zmsk ) 
     344 
     345         ENDIF 
     346 
     347         IF ( prodatqc%npvend(jobs,kvar) > 0 ) THEN 
     348 
     349            zobsk(:) = obfillflt 
     350 
     351            IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
     352 
     353               IF ( idayend == 0 )  THEN 
     354                  ! Daily averaged data 
     355 
     356                  ! vertically interpolate all 4 corners  
     357                  ista = prodatqc%npvsta(jobs,kvar)  
     358                  iend = prodatqc%npvend(jobs,kvar)  
     359                  inum_obs = iend - ista + 1  
     360                  ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs))  
     361                  IF ( prodatqc%lclim ) ALLOCATE( interp_corner_clim(2,2,inum_obs) ) 
     362                   
     363                  DO iin=1,2  
     364                     DO ijn=1,2  
     365 
     366                        IF ( k1dint == 1 ) THEN  
     367                           CALL obs_int_z1d_spl( kpk, &  
     368                              &     zinm(iin,ijn,:,iobs), &  
     369                              &     zobs2k, zgdept(iin,ijn,:,iobs), &  
     370                              &     zmask(iin,ijn,:,iobs))  
     371 
     372                           IF ( prodatqc%lclim ) THEN 
     373                              CALL obs_int_z1d_spl( kpk, &  
     374                                 &     zclim(iin,ijn,:,iobs), &  
     375                                 &     zclm2k, zgdept(iin,ijn,:,iobs), &  
     376                                 &     zmask(iin,ijn,:,iobs))  
     377                           ENDIF 
     378 
     379                        ENDIF  
     380        
     381                        CALL obs_level_search(kpk, &  
     382                           &    zgdept(iin,ijn,:,iobs), &  
     383                           &    inum_obs, prodatqc%var(kvar)%vdep(ista:iend), &  
     384                           &    iv_indic)  
     385 
     386                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, &  
     387                           &    prodatqc%var(kvar)%vdep(ista:iend), &  
     388                           &    zinm(iin,ijn,:,iobs), &  
     389                           &    zobs2k, interp_corner(iin,ijn,:), &  
     390                           &    zgdept(iin,ijn,:,iobs), &  
     391                           &    zmask(iin,ijn,:,iobs))  
     392 
     393                        IF ( prodatqc%lclim ) THEN 
     394                           CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, &  
     395                              &    prodatqc%var(kvar)%vdep(ista:iend), &  
     396                              &    zclim(iin,ijn,:,iobs), &  
     397                              &    zclm2k, interp_corner_clim(iin,ijn,:), &  
     398                              &    zgdept(iin,ijn,:,iobs), &  
     399                              &    zmask(iin,ijn,:,iobs))  
     400                        ENDIF 
     401                         
     402                     ENDDO  
     403                  ENDDO  
     404 
     405               ENDIF !idayend 
     406 
     407            ELSE    
     408 
     409               ! Point data  
     410      
     411               ! vertically interpolate all 4 corners  
     412               ista = prodatqc%npvsta(jobs,kvar)  
     413               iend = prodatqc%npvend(jobs,kvar)  
     414               inum_obs = iend - ista + 1  
     415               ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs))  
     416               IF ( prodatqc%lclim ) ALLOCATE( interp_corner_clim(2,2,inum_obs) )                   
     417               DO iin=1,2   
     418                  DO ijn=1,2  
     419                     
     420                     IF ( k1dint == 1 ) THEN  
     421                        CALL obs_int_z1d_spl( kpk, &  
     422                           &    zint(iin,ijn,:,iobs),&  
     423                           &    zobs2k, zgdept(iin,ijn,:,iobs), &  
     424                           &    zmask(iin,ijn,:,iobs))  
     425 
     426                        IF ( prodatqc%lclim ) THEN 
     427                           CALL obs_int_z1d_spl( kpk, &  
     428                              &    zclim(iin,ijn,:,iobs),&  
     429                              &    zclm2k, zgdept(iin,ijn,:,iobs), &  
     430                              &    zmask(iin,ijn,:,iobs))  
     431                        ENDIF 
     432   
     433                     ENDIF  
     434        
     435                     CALL obs_level_search(kpk, &  
     436                         &        zgdept(iin,ijn,:,iobs),&  
     437                         &        inum_obs, prodatqc%var(kvar)%vdep(ista:iend), &  
     438                         &        iv_indic)  
     439 
     440                     CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     &  
     441                         &          prodatqc%var(kvar)%vdep(ista:iend),     &  
     442                         &          zint(iin,ijn,:,iobs),            &  
     443                         &          zobs2k,interp_corner(iin,ijn,:), &  
     444                         &          zgdept(iin,ijn,:,iobs),         &  
     445                         &          zmask(iin,ijn,:,iobs) )       
     446 
     447                     IF ( prodatqc%lclim ) THEN 
     448                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     &  
     449                            &          prodatqc%var(kvar)%vdep(ista:iend),     &  
     450                            &          zclim(iin,ijn,:,iobs),            &  
     451                            &          zclm2k,interp_corner_clim(iin,ijn,:), &  
     452                            &          zgdept(iin,ijn,:,iobs),         &  
     453                            &          zmask(iin,ijn,:,iobs) )    
     454                     ENDIF    
    303455          
    304          ! Horizontal weights and vertical mask 
    305  
    306          IF ( ( prodatqc%npvend(jobs,1) > 0 ) .OR. & 
    307             & ( prodatqc%npvend(jobs,2) > 0 ) ) THEN 
    308  
    309             CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi,     & 
    310                &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
    311                &                   zmask(:,:,:,iobs), zweig, zobsmask ) 
    312  
    313          ENDIF 
    314  
    315          IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 
    316  
    317             zobsk(:) = obfillflt 
    318  
    319        IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
    320  
    321                IF ( idayend == 0 )  THEN 
     456                  ENDDO  
     457               ENDDO  
     458              
     459            ENDIF  
     460 
     461            !-------------------------------------------------------------  
     462            ! Compute the horizontal interpolation for every profile level  
     463            !-------------------------------------------------------------  
     464              
     465            DO ikn=1,inum_obs  
     466               iend=ista+ikn-1 
    322467                   
    323                   ! Daily averaged moored buoy (MRB) data 
    324                    
    325                   CALL obs_int_h2d( kpk, kpk,      & 
    326                      &              zweig, zinmt(:,:,:,iobs), zobsk ) 
    327                    
    328                    
    329                ELSE 
    330                 
    331                   CALL ctl_stop( ' A nonzero' //     & 
    332                      &           ' number of profile T BUOY data should' // & 
    333                      &           ' only occur at the end of a given day' ) 
    334  
     468               zweig(:,:,1) = 0._wp  
     469    
     470               ! This code forces the horizontal weights to be   
     471               ! zero IF the observation is below the bottom of the   
     472               ! corners of the interpolation nodes, Or if it is in   
     473               ! the mask. This is important for observations near   
     474               ! steep bathymetry  
     475               DO iin=1,2  
     476                  DO ijn=1,2  
     477      
     478                     depth_loop: DO ik=kpk,2,-1  
     479                        IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN    
     480                             
     481                           zweig(iin,ijn,1) = &   
     482                              & zweig1(iin,ijn,1) * &  
     483                              & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) &  
     484                              &  - prodatqc%var(kvar)%vdep(iend)),0._wp)  
     485                             
     486                           EXIT depth_loop 
     487 
     488                        ENDIF  
     489 
     490                     ENDDO depth_loop 
     491      
     492                  ENDDO  
     493               ENDDO  
     494    
     495               CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), &  
     496                  &              prodatqc%var(kvar)%vmod(iend:iend) )  
     497 
     498               IF ( prodatqc%lclim ) THEN 
     499                  CALL obs_int_h2d( 1, 1, zweig, interp_corner_clim(:,:,ikn), &  
     500                     &              prodatqc%var(kvar)%vclm(iend:iend) ) 
    335501               ENDIF 
    336            
    337             ELSE  
    338                 
    339                ! Point data 
    340  
    341                CALL obs_int_h2d( kpk, kpk,      & 
    342                   &              zweig, zintt(:,:,:,iobs), zobsk ) 
    343  
    344             ENDIF 
    345  
    346             !------------------------------------------------------------- 
    347             ! Compute vertical second-derivative of the interpolating  
    348             ! polynomial at obs points 
    349             !------------------------------------------------------------- 
    350              
    351             IF ( k1dint == 1 ) THEN 
    352                CALL obs_int_z1d_spl( kpk, zobsk, zobs2k,   & 
    353                   &                  pgdept, zobsmask ) 
    354             ENDIF 
    355              
    356             !----------------------------------------------------------------- 
    357             !  Vertical interpolation to the observation point 
    358             !----------------------------------------------------------------- 
    359             ista = prodatqc%npvsta(jobs,1) 
    360             iend = prodatqc%npvend(jobs,1) 
    361             CALL obs_int_z1d( kpk,                & 
    362                & prodatqc%var(1)%mvk(ista:iend),  & 
    363                & k1dint, iend - ista + 1,         & 
    364                & prodatqc%var(1)%vdep(ista:iend), & 
    365                & zobsk, zobs2k,                   & 
    366                & prodatqc%var(1)%vmod(ista:iend), & 
    367                & pgdept, zobsmask ) 
    368  
    369          ENDIF 
    370  
    371          IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
    372  
    373             zobsk(:) = obfillflt 
    374  
    375             IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
    376  
    377                IF ( idayend == 0 )  THEN 
    378  
    379                   ! Daily averaged moored buoy (MRB) data 
    380                    
    381                   CALL obs_int_h2d( kpk, kpk,      & 
    382                      &              zweig, zinms(:,:,:,iobs), zobsk ) 
    383                    
    384                ELSE 
    385  
    386                   CALL ctl_stop( ' A nonzero' //     & 
    387                      &           ' number of profile S BUOY data should' // & 
    388                      &           ' only occur at the end of a given day' ) 
    389  
    390                ENDIF 
    391  
    392             ELSE 
    393                 
    394                ! Point data 
    395  
    396                CALL obs_int_h2d( kpk, kpk,      & 
    397                   &              zweig, zints(:,:,:,iobs), zobsk ) 
    398  
    399             ENDIF 
    400  
    401  
    402             !------------------------------------------------------------- 
    403             ! Compute vertical second-derivative of the interpolating  
    404             ! polynomial at obs points 
    405             !------------------------------------------------------------- 
    406              
    407             IF ( k1dint == 1 ) THEN 
    408                CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 
    409                   &                  pgdept, zobsmask ) 
    410             ENDIF 
    411              
    412             !---------------------------------------------------------------- 
    413             !  Vertical interpolation to the observation point 
    414             !---------------------------------------------------------------- 
    415             ista = prodatqc%npvsta(jobs,2) 
    416             iend = prodatqc%npvend(jobs,2) 
    417             CALL obs_int_z1d( kpk, & 
    418                & prodatqc%var(2)%mvk(ista:iend),& 
    419                & k1dint, iend - ista + 1, & 
    420                & prodatqc%var(2)%vdep(ista:iend),& 
    421                & zobsk, zobs2k, & 
    422                & prodatqc%var(2)%vmod(ista:iend),& 
    423                & pgdept, zobsmask ) 
    424  
    425          ENDIF 
    426  
    427       END DO 
     502 
     503                  ! Set QC flag for any observations found below the bottom 
     504                  ! needed as the check here is more strict than that in obs_prep 
     505               IF (sum(zweig) == 0.0_wp) prodatqc%var(kvar)%nvqc(iend:iend)=4 
    428506  
     507            ENDDO  
     508  
     509            DEALLOCATE(interp_corner,iv_indic)  
     510            IF ( prodatqc%lclim ) DEALLOCATE( interp_corner_clim )          
     511              
     512         ENDIF 
     513 
     514      ENDDO 
     515 
    429516      ! Deallocate the data for interpolation 
    430       DEALLOCATE( & 
    431          & igrdi, & 
    432          & igrdj, & 
    433          & zglam, & 
    434          & zgphi, & 
    435          & zmask, & 
    436          & zintt, & 
    437          & zints  & 
     517      DEALLOCATE(  & 
     518         & igrdi,  & 
     519         & igrdj,  & 
     520         & zglam,  & 
     521         & zgphi,  & 
     522         & zmask,  & 
     523         & zint,   & 
     524         & zgdept, & 
     525         & zgdepw  & 
    438526         & ) 
     527 
     528      IF ( prodatqc%lclim ) DEALLOCATE( zclim ) 
     529       
    439530      ! At the end of the day also get interpolated means 
    440       IF ( idayend == 0 ) THEN 
    441          DEALLOCATE( & 
    442             & zinmt,  & 
    443             & zinms   & 
    444             & ) 
    445       ENDIF 
    446  
    447       prodatqc%nprofup = prodatqc%nprofup + ipro  
    448        
    449    END SUBROUTINE obs_pro_opt 
    450  
    451    SUBROUTINE obs_sla_opt( sladatqc, kt, kpi, kpj, kit000, & 
    452       &                    psshn, psshmask, k2dint ) 
     531      IF ( ld_dailyav .AND. idayend == 0 ) THEN 
     532         DEALLOCATE( zinm ) 
     533      ENDIF 
     534 
     535      IF ( kvar == prodatqc%nvar ) THEN 
     536         prodatqc%nprofup = prodatqc%nprofup + ipro  
     537      ENDIF 
     538 
     539   END SUBROUTINE obs_prof_opt 
     540 
     541   SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj,            & 
     542      &                     kit000, kdaystp, psurf, pclim, psurfmask,   & 
     543      &                     k2dint, ldnightav, plamscl, pphiscl, & 
     544      &                     lindegrees, kmeanstp ) 
     545 
    453546      !!----------------------------------------------------------------------- 
    454547      !! 
    455       !!                     ***  ROUTINE obs_sla_opt  *** 
    456       !! 
    457       !! ** Purpose : Compute the model counterpart of sea level anomaly 
     548      !!                     ***  ROUTINE obs_surf_opt  *** 
     549      !! 
     550      !! ** Purpose : Compute the model counterpart of surface 
    458551      !!              data by interpolating from the model grid to the  
    459552      !!              observation point. 
    … …  
    462555      !!              the model values at the corners of the surrounding grid box. 
    463556      !! 
    464       !!    The now model SSH is first computed at the obs (lon, lat) point. 
     557      !!    The new model value is first computed at the obs (lon, lat) point. 
    465558      !! 
    466559      !!    Several horizontal interpolation schemes are available: 
    … …  
    470563      !!        - bilinear (quadrilateral grid)    (k2dint = 3) 
    471564      !!        - polynomial (quadrilateral grid)  (k2dint = 4) 
    472       !!   
    473       !!    The sea level anomaly at the observation points is then computed  
    474       !!    by removing a mean dynamic topography (defined at the obs. point). 
     565      !! 
     566      !!    Two horizontal averaging schemes are also available: 
     567      !!        - weighted radial footprint        (k2dint = 5) 
     568      !!        - weighted rectangular footprint   (k2dint = 6) 
     569      !! 
    475570      !! 
    476571      !! ** Action  : 
    … …  
    478573      !! History : 
    479574      !!      ! 07-03 (A. Weaver) 
     575      !!      ! 15-02 (M. Martin) Combined routine for surface types 
     576      !!      ! 17-03 (M. Martin) Added horizontal averaging options 
    480577      !!----------------------------------------------------------------------- 
    481    
     578 
    482579      !! * Modules used 
    483580      USE obs_surf_def  ! Definition of storage space for surface observations 
    … …  
    486583 
    487584      !! * Arguments 
    488       TYPE(obs_surf), INTENT(INOUT) :: sladatqc     ! Subset of surface data not failing screening 
    489       INTEGER, INTENT(IN) :: kt      ! Time step 
    490       INTEGER, INTENT(IN) :: kpi     ! Model grid parameters 
     585      TYPE(obs_surf), INTENT(INOUT) :: & 
     586         & surfdataqc                  ! Subset of surface data passing QC 
     587      INTEGER, INTENT(IN) :: kt        ! Time step 
     588      INTEGER, INTENT(IN) :: kpi       ! Model grid parameters 
    491589      INTEGER, INTENT(IN) :: kpj 
    492       INTEGER, INTENT(IN) :: kit000   ! Number of the first time step  
    493                                       !   (kit000-1 = restart time) 
    494       INTEGER, INTENT(IN) :: k2dint   ! Horizontal interpolation type (see header) 
    495       REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    496          & psshn,  &    ! Model SSH field 
    497          & psshmask     ! Land-sea mask 
    498           
     590      INTEGER, INTENT(IN) :: kit000    ! Number of the first time step  
     591                                       !   (kit000-1 = restart time) 
     592      INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day 
     593      INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
     594      INTEGER, INTENT(IN), OPTIONAL :: & 
     595                             kmeanstp  ! Number of time steps for the time meaning 
     596                                       ! Averaging is triggered if present and greater than one                     
     597      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
     598         & psurf,  &                   ! Model surface field 
     599         & pclim,  &                   ! Climatological surface field          
     600         & psurfmask                   ! Land-sea mask 
     601      LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data 
     602      REAL(KIND=wp), INTENT(IN) :: & 
     603         & plamscl, &                  ! Diameter in metres of obs footprint in E/W, N/S directions 
     604         & pphiscl                     ! This is the full width (rather than half-width) 
     605      LOGICAL, INTENT(IN) :: & 
     606         & lindegrees                  ! T=> plamscl and pphiscl are specified in degrees, F=> in metres 
     607 
    499608      !! * Local declarations 
    500609      INTEGER :: ji 
    … …  
    502611      INTEGER :: jobs 
    503612      INTEGER :: inrc 
    504       INTEGER :: isla 
     613      INTEGER :: isurf 
    505614      INTEGER :: iobs 
    506       REAL(KIND=wp) :: zlam 
    507       REAL(KIND=wp) :: zphi 
    508       REAL(KIND=wp) :: zext(1), zobsmask(1) 
    509       REAL(kind=wp), DIMENSION(2,2,1) :: & 
    510          & zweig 
     615      INTEGER :: imaxifp, imaxjfp 
     616      INTEGER :: imodi, imodj 
     617      INTEGER :: idayend 
     618      INTEGER :: imeanend 
     619      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
     620         & igrdi,   & 
     621         & igrdj,   & 
     622         & igrdip1, & 
     623         & igrdjp1 
     624      INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 
     625         & icount_night,      & 
     626         & imask_night 
     627      REAL(wp) :: zlam 
     628      REAL(wp) :: zphi 
     629      REAL(wp), DIMENSION(1) :: zext, zobsmask, zclm 
     630      REAL(wp) :: zdaystp 
     631      REAL(wp) :: zmeanstp 
    511632      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    512          & zmask, & 
    513          & zsshl, & 
    514          & zglam, & 
    515          & zgphi 
    516       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    517          & igrdi, & 
    518          & igrdj 
    519  
     633         & zweig,  & 
     634         & zmask,  & 
     635         & zsurf,  & 
     636         & zsurfm, & 
     637         & zsurftmp, & 
     638         & zclim,  & 
     639         & zglam,  & 
     640         & zgphi,  & 
     641         & zglamf, & 
     642         & zgphif 
     643 
     644      REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 
     645         & zintmp,  & 
     646         & zouttmp, & 
     647         & zmeanday    ! to compute model sst in region of 24h daylight (pole) 
     648 
     649      LOGICAL :: l_timemean 
     650          
    520651      !------------------------------------------------------------------------ 
    521652      ! Local initialization  
    522653      !------------------------------------------------------------------------ 
    523       ! ... Record and data counters 
     654      ! Record and data counters 
    524655      inrc = kt - kit000 + 2 
    525       isla = sladatqc%nsstp(inrc) 
     656      isurf = surfdataqc%nsstp(inrc) 
     657 
     658      l_timemean = .FALSE. 
     659      IF ( PRESENT( kmeanstp ) ) THEN 
     660         IF ( kmeanstp > 1 ) l_timemean = .TRUE. 
     661      ENDIF 
     662 
     663      ! Work out the maximum footprint size for the  
     664      ! interpolation/averaging in model grid-points - has to be even. 
     665 
     666      CALL obs_max_fpsize( k2dint, plamscl, pphiscl, lindegrees, psurfmask, imaxifp, imaxjfp ) 
     667 
     668 
     669      IF ( l_timemean ) THEN 
     670         ! Initialize time mean for first timestep 
     671         imeanend = MOD( kt - kit000 + 1, kmeanstp ) 
     672         IF (lwp) WRITE(numout,*) 'Obs time mean ', kt, kit000, kmeanstp, imeanend 
     673 
     674         ! Added kt == 0 test to catch restart case  
     675         IF ( ( imeanend == 1 ) .OR. ( kt == 0 ) ) THEN 
     676            IF (lwp) WRITE(numout,*) 'Reset surfdataqc%vdmean on time-step: ',kt 
     677            DO jj = 1, jpj 
     678               DO ji = 1, jpi 
     679                  surfdataqc%vdmean(ji,jj) = 0.0 
     680               END DO 
     681            END DO 
     682         ENDIF 
     683 
     684         ! On each time-step, increment the field for computing time mean 
     685         IF (lwp) WRITE(numout,*)'Accumulating surfdataqc%vdmean on time-step: ',kt 
     686         DO jj = 1, jpj 
     687            DO ji = 1, jpi 
     688               surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 
     689                  &                        + psurf(ji,jj) 
     690            END DO 
     691         END DO 
     692 
     693         ! Compute the time mean at the end of time period 
     694         IF ( imeanend == 0 ) THEN 
     695            zmeanstp = 1.0 / REAL( kmeanstp ) 
     696            IF (lwp) WRITE(numout,*)'Calculating surfdataqc%vdmean time mean on time-step: ',kt,' with weight: ',zmeanstp 
     697            DO jj = 1, jpj 
     698               DO ji = 1, jpi 
     699                  surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 
     700                     &                       * zmeanstp 
     701               END DO 
     702            END DO 
     703         ENDIF 
     704      ENDIF !l_timemean 
     705 
     706 
     707      IF ( ldnightav ) THEN 
     708 
     709      ! Initialize array for night mean 
     710         IF ( kt == 0 ) THEN 
     711            ALLOCATE ( icount_night(kpi,kpj) ) 
     712            ALLOCATE ( imask_night(kpi,kpj) ) 
     713            ALLOCATE ( zintmp(kpi,kpj) ) 
     714            ALLOCATE ( zouttmp(kpi,kpj) ) 
     715            ALLOCATE ( zmeanday(kpi,kpj) ) 
     716            nday_qsr = -1   ! initialisation flag for nbc_dcy 
     717         ENDIF 
     718 
     719         ! Night-time means are calculated for night-time values over timesteps: 
     720         !  [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ..... 
     721         idayend = MOD( kt - kit000 + 1, kdaystp ) 
     722 
     723         ! Initialize night-time mean for first timestep of the day 
     724         IF ( idayend == 1 .OR. kt == 0 ) THEN 
     725            DO jj = 1, jpj 
     726               DO ji = 1, jpi 
     727                  surfdataqc%vdmean(ji,jj) = 0.0 
     728                  zmeanday(ji,jj) = 0.0 
     729                  icount_night(ji,jj) = 0 
     730               END DO 
     731            END DO 
     732         ENDIF 
     733 
     734         zintmp(:,:) = 0.0 
     735         zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 
     736         imask_night(:,:) = INT( zouttmp(:,:) ) 
     737 
     738         DO jj = 1, jpj 
     739            DO ji = 1, jpi 
     740               ! Increment the temperature field for computing night mean and counter 
     741               surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj)  & 
     742                      &                    + psurf(ji,jj) * REAL( imask_night(ji,jj) ) 
     743               zmeanday(ji,jj)          = zmeanday(ji,jj) + psurf(ji,jj) 
     744               icount_night(ji,jj)      = icount_night(ji,jj) + imask_night(ji,jj) 
     745            END DO 
     746         END DO 
     747 
     748         ! Compute the night-time mean at the end of the day 
     749         zdaystp = 1.0 / REAL( kdaystp ) 
     750         IF ( idayend == 0 ) THEN 
     751            IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt 
     752            DO jj = 1, jpj 
     753               DO ji = 1, jpi 
     754                  ! Test if "no night" point 
     755                  IF ( icount_night(ji,jj) > 0 ) THEN 
     756                     surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 
     757                       &                        / REAL( icount_night(ji,jj) ) 
     758                  ELSE 
     759                     !At locations where there is no night (e.g. poles), 
     760                     ! calculate daily mean instead of night-time mean. 
     761                     surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 
     762                  ENDIF 
     763               END DO 
     764            END DO 
     765         ENDIF 
     766 
     767      ENDIF 
    526768 
    527769      ! Get the data for interpolation 
    528770 
    529771      ALLOCATE( & 
    530          & igrdi(2,2,isla), & 
    531          & igrdj(2,2,isla), & 
    532          & zglam(2,2,isla), & 
    533          & zgphi(2,2,isla), & 
    534          & zmask(2,2,isla), & 
    535          & zsshl(2,2,isla)  & 
     772         & zweig(imaxifp,imaxjfp,1),      & 
     773         & igrdi(imaxifp,imaxjfp,isurf), & 
     774         & igrdj(imaxifp,imaxjfp,isurf), & 
     775         & zglam(imaxifp,imaxjfp,isurf), & 
     776         & zgphi(imaxifp,imaxjfp,isurf), & 
     777         & zmask(imaxifp,imaxjfp,isurf), & 
     778         & zsurf(imaxifp,imaxjfp,isurf), & 
     779         & zsurftmp(imaxifp,imaxjfp,isurf),  & 
     780         & zglamf(imaxifp+1,imaxjfp+1,isurf), & 
     781         & zgphif(imaxifp+1,imaxjfp+1,isurf), & 
     782         & igrdip1(imaxifp+1,imaxjfp+1,isurf), & 
     783         & igrdjp1(imaxifp+1,imaxjfp+1,isurf) & 
    536784         & ) 
     785 
     786      IF ( surfdataqc%lclim ) ALLOCATE( zclim(imaxifp,imaxjfp,isurf) ) 
     787 
     788      DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 
     789         iobs = jobs - surfdataqc%nsurfup 
     790         DO ji = 0, imaxifp 
     791            imodi = surfdataqc%mi(jobs) - int(imaxifp/2) + ji - 1 
     792             
     793            !Deal with wrap around in longitude 
     794            IF ( imodi < 1      ) imodi = imodi + jpiglo 
     795            IF ( imodi > jpiglo ) imodi = imodi - jpiglo 
     796             
     797            DO jj = 0, imaxjfp 
     798               imodj = surfdataqc%mj(jobs) - int(imaxjfp/2) + jj - 1 
     799               !If model values are out of the domain to the north/south then 
     800               !set them to be the edge of the domain 
     801               IF ( imodj < 1      ) imodj = 1 
     802               IF ( imodj > jpjglo ) imodj = jpjglo 
     803 
     804               igrdip1(ji+1,jj+1,iobs) = imodi 
     805               igrdjp1(ji+1,jj+1,iobs) = imodj 
     806                
     807               IF ( ji >= 1 .AND. jj >= 1 ) THEN 
     808                  igrdi(ji,jj,iobs) = imodi 
     809                  igrdj(ji,jj,iobs) = imodj 
     810               ENDIF 
     811                
     812            END DO 
     813         END DO 
     814      END DO 
     815 
     816      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 
     817         &                  igrdi, igrdj, glamt, zglam ) 
     818      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 
     819         &                  igrdi, igrdj, gphit, zgphi ) 
     820      CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 
     821         &                  igrdi, igrdj, psurfmask, zmask ) 
     822 
     823      ! At the end of the averaging period get interpolated means 
     824      IF ( l_timemean ) THEN 
     825         IF ( imeanend == 0 ) THEN 
     826            ALLOCATE( zsurfm(imaxifp,imaxjfp,isurf) ) 
     827            IF (lwp) WRITE(numout,*)' Interpolating the time mean values on time step: ',kt 
     828            CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 
     829               &                  igrdi, igrdj, surfdataqc%vdmean(:,:), zsurfm ) 
     830         ENDIF 
     831      ELSE 
     832         CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 
     833            &                  igrdi, igrdj, psurf, zsurf ) 
     834      ENDIF 
     835 
     836      IF ( k2dint > 4 ) THEN          
     837         CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 
     838            &                  igrdip1, igrdjp1, glamf, zglamf ) 
     839         CALL obs_int_comm_2d( imaxifp+1, imaxjfp+1, isurf, kpi, kpj, & 
     840            &                  igrdip1, igrdjp1, gphif, zgphif ) 
     841      ENDIF 
    537842       
    538       DO jobs = sladatqc%nsurfup + 1, sladatqc%nsurfup + isla 
    539          iobs = jobs - sladatqc%nsurfup 
    540          igrdi(1,1,iobs) = sladatqc%mi(jobs)-1 
    541          igrdj(1,1,iobs) = sladatqc%mj(jobs)-1 
    542          igrdi(1,2,iobs) = sladatqc%mi(jobs)-1 
    543          igrdj(1,2,iobs) = sladatqc%mj(jobs) 
    544          igrdi(2,1,iobs) = sladatqc%mi(jobs) 
    545          igrdj(2,1,iobs) = sladatqc%mj(jobs)-1 
    546          igrdi(2,2,iobs) = sladatqc%mi(jobs) 
    547          igrdj(2,2,iobs) = sladatqc%mj(jobs) 
    548       END DO 
    549  
    550       CALL obs_int_comm_2d( 2, 2, isla, & 
    551          &                  igrdi, igrdj, glamt, zglam ) 
    552       CALL obs_int_comm_2d( 2, 2, isla, & 
    553          &                  igrdi, igrdj, gphit, zgphi ) 
    554       CALL obs_int_comm_2d( 2, 2, isla, & 
    555          &                  igrdi, igrdj, psshmask, zmask ) 
    556       CALL obs_int_comm_2d( 2, 2, isla, & 
    557          &                  igrdi, igrdj, psshn, zsshl ) 
     843      IF ( surfdataqc%lclim ) THEN  
     844         CALL obs_int_comm_2d( imaxifp, imaxjfp, isurf, kpi, kpj, & 
     845            &                  igrdi, igrdj, pclim, zclim ) 
     846      ENDIF 
     847 
     848      ! At the end of the day get interpolated means 
     849      IF ( idayend == 0 .AND. ldnightav ) THEN 
     850 
     851         ALLOCATE( & 
     852            & zsurfm(imaxifp,imaxjfp,isurf)  & 
     853            & ) 
     854 
     855         CALL obs_int_comm_2d( imaxifp,imaxjfp, isurf, kpi, kpj, igrdi, igrdj, & 
     856            &               surfdataqc%vdmean(:,:), zsurfm ) 
     857 
     858      ENDIF 
    558859 
    559860      ! Loop over observations 
    560  
    561       DO jobs = sladatqc%nsurfup + 1, sladatqc%nsurfup + isla 
    562  
    563          iobs = jobs - sladatqc%nsurfup 
    564  
    565          IF ( kt /= sladatqc%mstp(jobs) ) THEN 
    566              
     861      DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 
     862 
     863         iobs = jobs - surfdataqc%nsurfup 
     864 
     865         IF ( kt /= surfdataqc%mstp(jobs) ) THEN 
     866 
    567867            IF(lwp) THEN 
    568868               WRITE(numout,*) 
    … …  
    574874               WRITE(numout,*) ' Record  = ', jobs,                & 
    575875                  &            ' kt      = ', kt,                  & 
    576                   &            ' mstp    = ', sladatqc%mstp(jobs), & 
    577                   &            ' ntyp    = ', sladatqc%ntyp(jobs) 
     876                  &            ' mstp    = ', surfdataqc%mstp(jobs), & 
     877                  &            ' ntyp    = ', surfdataqc%ntyp(jobs) 
    578878            ENDIF 
    579             CALL ctl_stop( 'obs_sla_opt', 'Inconsistent time' ) 
    580              
    581          ENDIF 
    582           
    583          zlam = sladatqc%rlam(jobs) 
    584          zphi = sladatqc%rphi(jobs) 
    585  
    586          ! Get weights to interpolate the model SSH to the observation point 
    587          CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
    588             &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
    589             &                   zmask(:,:,iobs), zweig, zobsmask ) 
    590           
    591  
    592          ! Interpolate the model SSH to the observation point 
    593          CALL obs_int_h2d( 1, 1,      & 
    594             &              zweig, zsshl(:,:,iobs),  zext ) 
    595           
    596          sladatqc%rext(jobs,1) = zext(1) 
    597          ! ... Remove the MDT at the observation point 
    598          sladatqc%rmod(jobs,1) = sladatqc%rext(jobs,1) - sladatqc%rext(jobs,2) 
     879            CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' ) 
     880 
     881         ENDIF 
     882 
     883         zlam = surfdataqc%rlam(jobs) 
     884         zphi = surfdataqc%rphi(jobs) 
     885 
     886         IF (( ldnightav .AND. idayend == 0 ) .OR. (l_timemean .AND. imeanend == 0)) THEN 
     887            ! Night-time or N=kmeanstp timestep averaged data 
     888            zsurftmp(:,:,iobs) = zsurfm(:,:,iobs) 
     889         ELSE 
     890            zsurftmp(:,:,iobs) = zsurf(:,:,iobs) 
     891         ENDIF 
     892 
     893         IF (   ( .NOT. l_timemean ) .OR. &  
     894             &  ( l_timemean .AND. imeanend == 0) ) THEN 
     895            IF ( k2dint <= 4 ) THEN 
     896 
     897               ! Get weights to interpolate the model value to the observation point 
     898               CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
     899                  &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
     900                  &                   zmask(:,:,iobs), zweig, zobsmask ) 
     901 
     902               ! Interpolate the model value to the observation point  
     903               CALL obs_int_h2d( 1, 1, zweig, zsurftmp(:,:,iobs), zext ) 
     904 
     905               IF ( surfdataqc%lclim ) THEN   
     906                  CALL obs_int_h2d( 1, 1, zweig, zclim(:,:,iobs), zclm ) 
     907               ENDIF 
     908 
     909 
     910            ELSE 
     911 
     912               ! Get weights to average the model SLA to the observation footprint 
     913               CALL obs_avg_h2d_init( 1, 1, imaxifp, imaxjfp, k2dint, zlam,  zphi, & 
     914                  &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
     915                  &                   zglamf(:,:,iobs), zgphif(:,:,iobs), & 
     916                  &                   zmask(:,:,iobs), plamscl, pphiscl, & 
     917                  &                   lindegrees, zweig, zobsmask ) 
     918 
     919               ! Average the model SST to the observation footprint 
     920               CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 
     921                  &              zweig, zsurftmp(:,:,iobs),  zext ) 
     922 
     923               IF ( surfdataqc%lclim ) THEN   
     924                  CALL obs_avg_h2d( 1, 1, imaxifp, imaxjfp, & 
     925                     &              zweig, zclim(:,:,iobs),  zclm ) 
     926               ENDIF 
     927 
     928            ENDIF 
     929 
     930            IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN 
     931               ! ... Remove the MDT from the SSH at the observation point to get the SLA 
     932               surfdataqc%rext(jobs,1) = zext(1) 
     933               surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) 
     934            ELSE 
     935               surfdataqc%rmod(jobs,1) = zext(1) 
     936            ENDIF 
     937 
     938            IF ( surfdataqc%lclim ) surfdataqc%rclm(jobs,1) = zclm(1) 
     939 
     940            IF ( zext(1) == obfillflt ) THEN 
     941               ! If the observation value is a fill value, set QC flag to bad 
     942               surfdataqc%nqc(jobs) = 4 
     943            ENDIF          
     944         ENDIF 
    599945 
    600946      END DO 
    … …  
    602948      ! Deallocate the data for interpolation 
    603949      DEALLOCATE( & 
     950         & zweig, & 
    604951         & igrdi, & 
    605952         & igrdj, & 
    … …  
    607954         & zgphi, & 
    608955         & zmask, & 
    609          & zsshl  & 
     956         & zsurf, & 
     957         & zsurftmp, & 
     958         & zglamf, & 
     959         & zgphif, & 
     960         & igrdip1,& 
     961         & igrdjp1 & 
    610962         & ) 
    611963 
    612       sladatqc%nsurfup = sladatqc%nsurfup + isla 
    613  
    614    END SUBROUTINE obs_sla_opt 
    615  
    616    SUBROUTINE obs_sst_opt( sstdatqc, kt, kpi, kpj, kit000, kdaystp, & 
    617       &                    psstn, psstmask, k2dint, ld_nightav ) 
    618       !!----------------------------------------------------------------------- 
    619       !! 
    620       !!                     ***  ROUTINE obs_sst_opt  *** 
    621       !! 
    622       !! ** Purpose : Compute the model counterpart of surface temperature 
    623       !!              data by interpolating from the model grid to the  
    624       !!              observation point. 
    625       !! 
    626       !! ** Method  : Linearly interpolate to each observation point using  
    627       !!              the model values at the corners of the surrounding grid box. 
    628       !! 
    629       !!    The now model SST is first computed at the obs (lon, lat) point. 
    630       !! 
    631       !!    Several horizontal interpolation schemes are available: 
    632       !!        - distance-weighted (great circle) (k2dint = 0) 
    633       !!        - distance-weighted (small angle)  (k2dint = 1) 
    634       !!        - bilinear (geographical grid)     (k2dint = 2) 
    635       !!        - bilinear (quadrilateral grid)    (k2dint = 3) 
    636       !!        - polynomial (quadrilateral grid)  (k2dint = 4) 
    637       !! 
    638       !! 
    639       !! ** Action  : 
    640       !! 
    641       !! History : 
    642       !!        !  07-07  (S. Ricci ) : Original 
    643       !!       
    644       !!----------------------------------------------------------------------- 
    645  
    646       !! * Modules used 
    647       USE obs_surf_def  ! Definition of storage space for surface observations 
    648       USE sbcdcy 
    649  
    650       IMPLICIT NONE 
    651  
    652       !! * Arguments 
    653       TYPE(obs_surf), INTENT(INOUT) :: & 
    654          & sstdatqc     ! Subset of surface data not failing screening 
    655       INTEGER, INTENT(IN) :: kt        ! Time step 
    656       INTEGER, INTENT(IN) :: kpi       ! Model grid parameters 
    657       INTEGER, INTENT(IN) :: kpj 
    658       INTEGER, INTENT(IN) :: kit000    ! Number of the first time step  
    659                                        !   (kit000-1 = restart time) 
    660       INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
    661       INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day   
    662       REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    663          & psstn,  &    ! Model SST field 
    664          & psstmask     ! Land-sea mask 
    665  
    666       !! * Local declarations 
    667       INTEGER :: ji 
    668       INTEGER :: jj 
    669       INTEGER :: jobs 
    670       INTEGER :: inrc 
    671       INTEGER :: isst 
    672       INTEGER :: iobs 
    673       INTEGER :: idayend 
    674       REAL(KIND=wp) :: zlam 
    675       REAL(KIND=wp) :: zphi 
    676       REAL(KIND=wp) :: zext(1), zobsmask(1) 
    677       REAL(KIND=wp) :: zdaystp 
    678       INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 
    679          & icount_sstnight,      & 
    680          & imask_night 
    681       REAL(kind=wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 
    682          & zintmp, & 
    683          & zouttmp, &  
    684          & zmeanday    ! to compute model sst in region of 24h daylight (pole) 
    685       REAL(kind=wp), DIMENSION(2,2,1) :: & 
    686          & zweig 
    687       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    688          & zmask, & 
    689          & zsstl, & 
    690          & zsstm, & 
    691          & zglam, & 
    692          & zgphi 
    693       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    694          & igrdi, & 
    695          & igrdj 
    696       LOGICAL, INTENT(IN) :: ld_nightav 
    697  
    698       !----------------------------------------------------------------------- 
    699       ! Local initialization  
    700       !----------------------------------------------------------------------- 
    701       ! ... Record and data counters 
    702       inrc = kt - kit000 + 2 
    703       isst = sstdatqc%nsstp(inrc) 
    704  
    705       IF ( ld_nightav ) THEN 
    706  
    707       ! Initialize array for night mean 
    708  
    709       IF ( kt .EQ. 0 ) THEN 
    710          ALLOCATE ( icount_sstnight(kpi,kpj) ) 
    711          ALLOCATE ( imask_night(kpi,kpj) ) 
    712          ALLOCATE ( zintmp(kpi,kpj) ) 
    713          ALLOCATE ( zouttmp(kpi,kpj) ) 
    714          ALLOCATE ( zmeanday(kpi,kpj) ) 
    715          nday_qsr = -1   ! initialisation flag for nbc_dcy 
    716       ENDIF 
    717  
    718       ! Initialize daily mean for first timestep 
    719       idayend = MOD( kt - kit000 + 1, kdaystp ) 
    720  
    721       ! Added kt == 0 test to catch restart case  
    722       IF ( idayend == 1 .OR. kt == 0) THEN 
    723          IF (lwp) WRITE(numout,*) 'Reset sstdatqc%vdmean on time-step: ',kt 
    724          DO jj = 1, jpj 
    725             DO ji = 1, jpi 
    726                sstdatqc%vdmean(ji,jj) = 0.0 
    727                zmeanday(ji,jj) = 0.0 
    728                icount_sstnight(ji,jj) = 0 
    729             END DO 
    730          END DO 
    731       ENDIF 
    732  
    733       zintmp(:,:) = 0.0 
    734       zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 
    735       imask_night(:,:) = INT( zouttmp(:,:) ) 
    736  
    737       DO jj = 1, jpj 
    738          DO ji = 1, jpi 
    739             ! Increment the temperature field for computing night mean and counter 
    740             sstdatqc%vdmean(ji,jj) = sstdatqc%vdmean(ji,jj)  & 
    741                    &                        + psstn(ji,jj)*imask_night(ji,jj) 
    742             zmeanday(ji,jj)        = zmeanday(ji,jj) + psstn(ji,jj) 
    743             icount_sstnight(ji,jj) = icount_sstnight(ji,jj) + imask_night(ji,jj) 
    744          END DO 
    745       END DO 
    746     
    747       ! Compute the daily mean at the end of day 
    748  
    749       zdaystp = 1.0 / REAL( kdaystp ) 
    750  
    751       IF ( idayend == 0 ) THEN  
    752          DO jj = 1, jpj 
    753             DO ji = 1, jpi 
    754                ! Test if "no night" point 
    755                IF ( icount_sstnight(ji,jj) .NE. 0 ) THEN 
    756                   sstdatqc%vdmean(ji,jj) = sstdatqc%vdmean(ji,jj) & 
    757                     &                        / icount_sstnight(ji,jj)  
    758                ELSE 
    759                   sstdatqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 
    760                ENDIF 
    761             END DO 
    762          END DO 
    763       ENDIF 
    764  
    765       ENDIF 
    766  
    767       ! Get the data for interpolation 
    768        
    769       ALLOCATE( & 
    770          & igrdi(2,2,isst), & 
    771          & igrdj(2,2,isst), & 
    772          & zglam(2,2,isst), & 
    773          & zgphi(2,2,isst), & 
    774          & zmask(2,2,isst), & 
    775          & zsstl(2,2,isst)  & 
    776          & ) 
    777        
    778       DO jobs = sstdatqc%nsurfup + 1, sstdatqc%nsurfup + isst 
    779          iobs = jobs - sstdatqc%nsurfup 
    780          igrdi(1,1,iobs) = sstdatqc%mi(jobs)-1 
    781          igrdj(1,1,iobs) = sstdatqc%mj(jobs)-1 
    782          igrdi(1,2,iobs) = sstdatqc%mi(jobs)-1 
    783          igrdj(1,2,iobs) = sstdatqc%mj(jobs) 
    784          igrdi(2,1,iobs) = sstdatqc%mi(jobs) 
    785          igrdj(2,1,iobs) = sstdatqc%mj(jobs)-1 
    786          igrdi(2,2,iobs) = sstdatqc%mi(jobs) 
    787          igrdj(2,2,iobs) = sstdatqc%mj(jobs) 
    788       END DO 
    789        
    790       CALL obs_int_comm_2d( 2, 2, isst, & 
    791          &                  igrdi, igrdj, glamt, zglam ) 
    792       CALL obs_int_comm_2d( 2, 2, isst, & 
    793          &                  igrdi, igrdj, gphit, zgphi ) 
    794       CALL obs_int_comm_2d( 2, 2, isst, & 
    795          &                  igrdi, igrdj, psstmask, zmask ) 
    796       CALL obs_int_comm_2d( 2, 2, isst, & 
    797          &                  igrdi, igrdj, psstn, zsstl ) 
    798  
    799       ! At the end of the day get interpolated means 
    800       IF ( idayend == 0 .AND. ld_nightav ) THEN 
    801  
    802          ALLOCATE( & 
    803             & zsstm(2,2,isst)  & 
     964      IF ( surfdataqc%lclim ) DEALLOCATE( zclim ) 
     965 
     966      ! At the end of the day also deallocate night-time mean array 
     967      IF (( idayend == 0 .AND. ldnightav ) .OR. ( imeanend == 0 .AND. l_timemean )) THEN 
     968         DEALLOCATE( & 
     969            & zsurfm  & 
    804970            & ) 
    805  
    806          CALL obs_int_comm_2d( 2, 2, isst, igrdi, igrdj, & 
    807             &               sstdatqc%vdmean(:,:), zsstm ) 
    808  
    809       ENDIF 
    810  
    811       ! Loop over observations 
    812  
    813       DO jobs = sstdatqc%nsurfup + 1, sstdatqc%nsurfup + isst 
    814           
    815          iobs = jobs - sstdatqc%nsurfup 
    816           
    817          IF ( kt /= sstdatqc%mstp(jobs) ) THEN 
    818              
    819             IF(lwp) THEN 
    820                WRITE(numout,*) 
    821                WRITE(numout,*) ' E R R O R : Observation',              & 
    822                   &            ' time step is not consistent with the', & 
    823                   &            ' model time step' 
    824                WRITE(numout,*) ' =========' 
    825                WRITE(numout,*) 
    826                WRITE(numout,*) ' Record  = ', jobs,                & 
    827                   &            ' kt      = ', kt,                  & 
    828                   &            ' mstp    = ', sstdatqc%mstp(jobs), & 
    829                   &            ' ntyp    = ', sstdatqc%ntyp(jobs) 
    830             ENDIF 
    831             CALL ctl_stop( 'obs_sst_opt', 'Inconsistent time' ) 
    832              
    833          ENDIF 
    834           
    835          zlam = sstdatqc%rlam(jobs) 
    836          zphi = sstdatqc%rphi(jobs) 
    837           
    838          ! Get weights to interpolate the model SST to the observation point 
    839          CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
    840             &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
    841             &                   zmask(:,:,iobs), zweig, zobsmask ) 
    842              
    843          ! Interpolate the model SST to the observation point  
    844  
    845          IF ( ld_nightav ) THEN 
    846  
    847            IF ( idayend == 0 )  THEN 
    848                ! Daily averaged/diurnal cycle of SST  data 
    849                CALL obs_int_h2d( 1, 1,      &  
    850                      &              zweig, zsstm(:,:,iobs), zext ) 
    851             ELSE  
    852                CALL ctl_stop( ' ld_nightav is set to true: a nonzero' //     & 
    853                      &           ' number of night SST data should' // & 
    854                      &           ' only occur at the end of a given day' ) 
    855             ENDIF 
    856  
    857          ELSE 
    858  
    859             CALL obs_int_h2d( 1, 1,      & 
    860             &              zweig, zsstl(:,:,iobs),  zext ) 
    861  
    862          ENDIF 
    863          sstdatqc%rmod(jobs,1) = zext(1) 
    864           
    865       END DO 
    866        
    867       ! Deallocate the data for interpolation 
    868       DEALLOCATE( & 
    869          & igrdi, & 
    870          & igrdj, & 
    871          & zglam, & 
    872          & zgphi, & 
    873          & zmask, & 
    874          & zsstl  & 
    875          & ) 
    876  
    877       ! At the end of the day also get interpolated means 
    878       IF ( idayend == 0 .AND. ld_nightav ) THEN 
    879          DEALLOCATE( & 
    880             & zsstm  & 
    881             & ) 
    882       ENDIF 
    883        
    884       sstdatqc%nsurfup = sstdatqc%nsurfup + isst 
    885  
    886    END SUBROUTINE obs_sst_opt 
    887  
    888    SUBROUTINE obs_sss_opt 
    889       !!----------------------------------------------------------------------- 
    890       !! 
    891       !!                     ***  ROUTINE obs_sss_opt  *** 
    892       !! 
    893       !! ** Purpose : Compute the model counterpart of sea surface salinity 
    894       !!              data by interpolating from the model grid to the  
    895       !!              observation point. 
    896       !! 
    897       !! ** Method  :  
    898       !! 
    899       !! ** Action  : 
    900       !! 
    901       !! History : 
    902       !!      ! ??-??  
    903       !!----------------------------------------------------------------------- 
    904  
    905       IMPLICIT NONE 
    906  
    907    END SUBROUTINE obs_sss_opt 
    908  
    909    SUBROUTINE obs_seaice_opt( seaicedatqc, kt, kpi, kpj, kit000, & 
    910       &                    pseaicen, pseaicemask, k2dint ) 
    911  
    912       !!----------------------------------------------------------------------- 
    913       !! 
    914       !!                     ***  ROUTINE obs_seaice_opt  *** 
    915       !! 
    916       !! ** Purpose : Compute the model counterpart of surface temperature 
    917       !!              data by interpolating from the model grid to the  
    918       !!              observation point. 
    919       !! 
    920       !! ** Method  : Linearly interpolate to each observation point using  
    921       !!              the model values at the corners of the surrounding grid box. 
    922       !! 
    923       !!    The now model sea ice is first computed at the obs (lon, lat) point. 
    924       !! 
    925       !!    Several horizontal interpolation schemes are available: 
    926       !!        - distance-weighted (great circle) (k2dint = 0) 
    927       !!        - distance-weighted (small angle)  (k2dint = 1) 
    928       !!        - bilinear (geographical grid)     (k2dint = 2) 
    929       !!        - bilinear (quadrilateral grid)    (k2dint = 3) 
    930       !!        - polynomial (quadrilateral grid)  (k2dint = 4) 
    931       !! 
    932       !! 
    933       !! ** Action  : 
    934       !! 
    935       !! History : 
    936       !!        !  07-07  (S. Ricci ) : Original 
    937       !!       
    938       !!----------------------------------------------------------------------- 
    939  
    940       !! * Modules used 
    941       USE obs_surf_def  ! Definition of storage space for surface observations 
    942  
    943       IMPLICIT NONE 
    944  
    945       !! * Arguments 
    946       TYPE(obs_surf), INTENT(INOUT) :: seaicedatqc     ! Subset of surface data not failing screening 
    947       INTEGER, INTENT(IN) :: kt       ! Time step 
    948       INTEGER, INTENT(IN) :: kpi      ! Model grid parameters 
    949       INTEGER, INTENT(IN) :: kpj 
    950       INTEGER, INTENT(IN) :: kit000   ! Number of the first time step  
    951                                       !   (kit000-1 = restart time) 
    952       INTEGER, INTENT(IN) :: k2dint   ! Horizontal interpolation type (see header) 
    953       REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    954          & pseaicen,  &    ! Model sea ice field 
    955          & pseaicemask     ! Land-sea mask 
    956           
    957       !! * Local declarations 
    958       INTEGER :: ji 
    959       INTEGER :: jj 
    960       INTEGER :: jobs 
    961       INTEGER :: inrc 
    962       INTEGER :: iseaice 
    963       INTEGER :: iobs 
    964         
    965       REAL(KIND=wp) :: zlam 
    966       REAL(KIND=wp) :: zphi 
    967       REAL(KIND=wp) :: zext(1), zobsmask(1) 
    968       REAL(kind=wp), DIMENSION(2,2,1) :: & 
    969          & zweig 
    970       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    971          & zmask, & 
    972          & zseaicel, & 
    973          & zglam, & 
    974          & zgphi 
    975       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    976          & igrdi, & 
    977          & igrdj 
    978  
    979       !------------------------------------------------------------------------ 
    980       ! Local initialization  
    981       !------------------------------------------------------------------------ 
    982       ! ... Record and data counters 
    983       inrc = kt - kit000 + 2 
    984       iseaice = seaicedatqc%nsstp(inrc) 
    985  
    986       ! Get the data for interpolation 
    987        
    988       ALLOCATE( & 
    989          & igrdi(2,2,iseaice), & 
    990          & igrdj(2,2,iseaice), & 
    991          & zglam(2,2,iseaice), & 
    992          & zgphi(2,2,iseaice), & 
    993          & zmask(2,2,iseaice), & 
    994          & zseaicel(2,2,iseaice)  & 
    995          & ) 
    996        
    997       DO jobs = seaicedatqc%nsurfup + 1, seaicedatqc%nsurfup + iseaice 
    998          iobs = jobs - seaicedatqc%nsurfup 
    999          igrdi(1,1,iobs) = seaicedatqc%mi(jobs)-1 
    1000          igrdj(1,1,iobs) = seaicedatqc%mj(jobs)-1 
    1001          igrdi(1,2,iobs) = seaicedatqc%mi(jobs)-1 
    1002          igrdj(1,2,iobs) = seaicedatqc%mj(jobs) 
    1003          igrdi(2,1,iobs) = seaicedatqc%mi(jobs) 
    1004          igrdj(2,1,iobs) = seaicedatqc%mj(jobs)-1 
    1005          igrdi(2,2,iobs) = seaicedatqc%mi(jobs) 
    1006          igrdj(2,2,iobs) = seaicedatqc%mj(jobs) 
    1007       END DO 
    1008        
    1009       CALL obs_int_comm_2d( 2, 2, iseaice, & 
    1010          &                  igrdi, igrdj, glamt, zglam ) 
    1011       CALL obs_int_comm_2d( 2, 2, iseaice, & 
    1012          &                  igrdi, igrdj, gphit, zgphi ) 
    1013       CALL obs_int_comm_2d( 2, 2, iseaice, & 
    1014          &                  igrdi, igrdj, pseaicemask, zmask ) 
    1015       CALL obs_int_comm_2d( 2, 2, iseaice, & 
    1016          &                  igrdi, igrdj, pseaicen, zseaicel ) 
    1017        
    1018       DO jobs = seaicedatqc%nsurfup + 1, seaicedatqc%nsurfup + iseaice 
    1019           
    1020          iobs = jobs - seaicedatqc%nsurfup 
    1021           
    1022          IF ( kt /= seaicedatqc%mstp(jobs) ) THEN 
    1023              
    1024             IF(lwp) THEN 
    1025                WRITE(numout,*) 
    1026                WRITE(numout,*) ' E R R O R : Observation',              & 
    1027                   &            ' time step is not consistent with the', & 
    1028                   &            ' model time step' 
    1029                WRITE(numout,*) ' =========' 
    1030                WRITE(numout,*) 
    1031                WRITE(numout,*) ' Record  = ', jobs,                & 
    1032                   &            ' kt      = ', kt,                  & 
    1033                   &            ' mstp    = ', seaicedatqc%mstp(jobs), & 
    1034                   &            ' ntyp    = ', seaicedatqc%ntyp(jobs) 
    1035             ENDIF 
    1036             CALL ctl_stop( 'obs_seaice_opt', 'Inconsistent time' ) 
    1037              
    1038          ENDIF 
    1039           
    1040          zlam = seaicedatqc%rlam(jobs) 
    1041          zphi = seaicedatqc%rphi(jobs) 
    1042           
    1043          ! Get weights to interpolate the model sea ice to the observation point 
    1044          CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
    1045             &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
    1046             &                   zmask(:,:,iobs), zweig, zobsmask ) 
    1047           
    1048          ! ... Interpolate the model sea ice to the observation point 
    1049          CALL obs_int_h2d( 1, 1,      & 
    1050             &              zweig, zseaicel(:,:,iobs),  zext ) 
    1051           
    1052          seaicedatqc%rmod(jobs,1) = zext(1) 
    1053           
    1054       END DO 
    1055        
    1056       ! Deallocate the data for interpolation 
    1057       DEALLOCATE( & 
    1058          & igrdi,    & 
    1059          & igrdj,    & 
    1060          & zglam,    & 
    1061          & zgphi,    & 
    1062          & zmask,    & 
    1063          & zseaicel  & 
    1064          & ) 
    1065        
    1066       seaicedatqc%nsurfup = seaicedatqc%nsurfup + iseaice 
    1067  
    1068    END SUBROUTINE obs_seaice_opt 
    1069  
    1070    SUBROUTINE obs_vel_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 
    1071       &                    pun, pvn, pgdept, pumask, pvmask, k1dint, k2dint, & 
    1072       &                    ld_dailyav ) 
    1073       !!----------------------------------------------------------------------- 
    1074       !! 
    1075       !!                     ***  ROUTINE obs_vel_opt  *** 
    1076       !! 
    1077       !! ** Purpose : Compute the model counterpart of velocity profile 
    1078       !!              data by interpolating from the model grid to the  
    1079       !!              observation point. 
    1080       !! 
    1081       !! ** Method  : Linearly interpolate zonal and meridional components of velocity  
    1082       !!              to each observation point using the model values at the corners of  
    1083       !!              the surrounding grid box. The model velocity components are on a  
    1084       !!              staggered C- grid. 
    1085       !! 
    1086       !!    For velocity data from the TAO array, the model equivalent is 
    1087       !!    a daily mean velocity field. So, we first compute 
    1088       !!    the mean, then interpolate only at the end of the day. 
    1089       !! 
    1090       !! ** Action  : 
    1091       !! 
    1092       !! History : 
    1093       !!    ! 07-03 (K. Mogensen)      : Temperature and Salinity profiles 
    1094       !!    ! 08-10 (Maria Valdivieso) : Velocity component (U,V) profiles 
    1095       !!----------------------------------------------------------------------- 
    1096      
    1097       !! * Modules used 
    1098       USE obs_profiles_def ! Definition of storage space for profile obs. 
    1099  
    1100       IMPLICIT NONE 
    1101  
    1102       !! * Arguments 
    1103       TYPE(obs_prof), INTENT(INOUT) :: & 
    1104          & prodatqc        ! Subset of profile data not failing screening 
    1105       INTEGER, INTENT(IN) :: kt        ! Time step 
    1106       INTEGER, INTENT(IN) :: kpi       ! Model grid parameters 
    1107       INTEGER, INTENT(IN) :: kpj 
    1108       INTEGER, INTENT(IN) :: kpk  
    1109       INTEGER, INTENT(IN) :: kit000    ! Number of the first time step  
    1110                                        !   (kit000-1 = restart time) 
    1111       INTEGER, INTENT(IN) :: k1dint    ! Vertical interpolation type (see header) 
    1112       INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
    1113       INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day                     
    1114       REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    1115          & pun,    &    ! Model zonal component of velocity 
    1116          & pvn,    &    ! Model meridional component of velocity 
    1117          & pumask, &    ! Land-sea mask 
    1118          & pvmask       ! Land-sea mask 
    1119       REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 
    1120          & pgdept       ! Model array of depth levels 
    1121       LOGICAL, INTENT(IN) :: ld_dailyav 
    1122           
    1123       !! * Local declarations 
    1124       INTEGER :: ji 
    1125       INTEGER :: jj 
    1126       INTEGER :: jk 
    1127       INTEGER :: jobs 
    1128       INTEGER :: inrc 
    1129       INTEGER :: ipro 
    1130       INTEGER :: idayend 
    1131       INTEGER :: ista 
    1132       INTEGER :: iend 
    1133       INTEGER :: iobs 
    1134       INTEGER, DIMENSION(imaxavtypes) :: & 
    1135          & idailyavtypes 
    1136       REAL(KIND=wp) :: zlam 
    1137       REAL(KIND=wp) :: zphi 
    1138       REAL(KIND=wp) :: zdaystp 
    1139       REAL(KIND=wp), DIMENSION(kpk) :: & 
    1140          & zobsmasku, & 
    1141          & zobsmaskv, & 
    1142          & zobsmask,  & 
    1143          & zobsk,     & 
    1144          & zobs2k 
    1145       REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 
    1146          & zweigu,zweigv 
    1147       REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
    1148          & zumask, zvmask, & 
    1149          & zintu, & 
    1150          & zintv, & 
    1151          & zinmu, & 
    1152          & zinmv 
    1153       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    1154          & zglamu, zglamv, & 
    1155          & zgphiu, zgphiv 
    1156       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    1157          & igrdiu, & 
    1158          & igrdju, & 
    1159          & igrdiv, & 
    1160          & igrdjv 
    1161  
    1162       !------------------------------------------------------------------------ 
    1163       ! Local initialization  
    1164       !------------------------------------------------------------------------ 
    1165       ! ... Record and data counters 
    1166       inrc = kt - kit000 + 2 
    1167       ipro = prodatqc%npstp(inrc) 
    1168  
    1169       ! Initialize daily mean for first timestep 
    1170       idayend = MOD( kt - kit000 + 1, kdaystp ) 
    1171  
    1172       ! Added kt == 0 test to catch restart case  
    1173       IF ( idayend == 1 .OR. kt == 0) THEN 
    1174          IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 
    1175          prodatqc%vdmean(:,:,:,1) = 0.0 
    1176          prodatqc%vdmean(:,:,:,2) = 0.0 
    1177       ENDIF 
    1178  
    1179       ! Increment the zonal velocity field for computing daily mean 
    1180       prodatqc%vdmean(:,:,:,1) = prodatqc%vdmean(:,:,:,1) + pun(:,:,:) 
    1181       ! Increment the meridional velocity field for computing daily mean 
    1182       prodatqc%vdmean(:,:,:,2) = prodatqc%vdmean(:,:,:,2) + pvn(:,:,:) 
    1183     
    1184       ! Compute the daily mean at the end of day 
    1185       zdaystp = 1.0 / REAL( kdaystp ) 
    1186       IF ( idayend == 0 ) THEN 
    1187          prodatqc%vdmean(:,:,:,1) = prodatqc%vdmean(:,:,:,1) * zdaystp 
    1188          prodatqc%vdmean(:,:,:,2) = prodatqc%vdmean(:,:,:,2) * zdaystp 
    1189       ENDIF 
    1190  
    1191       ! Get the data for interpolation 
    1192       ALLOCATE( & 
    1193          & igrdiu(2,2,ipro),      & 
    1194          & igrdju(2,2,ipro),      & 
    1195          & igrdiv(2,2,ipro),      & 
    1196          & igrdjv(2,2,ipro),      & 
    1197          & zglamu(2,2,ipro), zglamv(2,2,ipro), & 
    1198          & zgphiu(2,2,ipro), zgphiv(2,2,ipro), & 
    1199          & zumask(2,2,kpk,ipro), zvmask(2,2,kpk,ipro), & 
    1200          & zintu(2,2,kpk,ipro),  & 
    1201          & zintv(2,2,kpk,ipro)   & 
    1202          & ) 
    1203  
    1204       DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
    1205          iobs = jobs - prodatqc%nprofup 
    1206          igrdiu(1,1,iobs) = prodatqc%mi(jobs,1)-1 
    1207          igrdju(1,1,iobs) = prodatqc%mj(jobs,1)-1 
    1208          igrdiu(1,2,iobs) = prodatqc%mi(jobs,1)-1 
    1209          igrdju(1,2,iobs) = prodatqc%mj(jobs,1) 
    1210          igrdiu(2,1,iobs) = prodatqc%mi(jobs,1) 
    1211          igrdju(2,1,iobs) = prodatqc%mj(jobs,1)-1 
    1212          igrdiu(2,2,iobs) = prodatqc%mi(jobs,1) 
    1213          igrdju(2,2,iobs) = prodatqc%mj(jobs,1) 
    1214          igrdiv(1,1,iobs) = prodatqc%mi(jobs,2)-1 
    1215          igrdjv(1,1,iobs) = prodatqc%mj(jobs,2)-1 
    1216          igrdiv(1,2,iobs) = prodatqc%mi(jobs,2)-1 
    1217          igrdjv(1,2,iobs) = prodatqc%mj(jobs,2) 
    1218          igrdiv(2,1,iobs) = prodatqc%mi(jobs,2) 
    1219          igrdjv(2,1,iobs) = prodatqc%mj(jobs,2)-1 
    1220          igrdiv(2,2,iobs) = prodatqc%mi(jobs,2) 
    1221          igrdjv(2,2,iobs) = prodatqc%mj(jobs,2) 
    1222       END DO 
    1223  
    1224       CALL obs_int_comm_2d( 2, 2, ipro, igrdiu, igrdju, glamu, zglamu ) 
    1225       CALL obs_int_comm_2d( 2, 2, ipro, igrdiu, igrdju, gphiu, zgphiu ) 
    1226       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, pumask, zumask ) 
    1227       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, pun, zintu ) 
    1228  
    1229       CALL obs_int_comm_2d( 2, 2, ipro, igrdiv, igrdjv, glamv, zglamv ) 
    1230       CALL obs_int_comm_2d( 2, 2, ipro, igrdiv, igrdjv, gphiv, zgphiv ) 
    1231       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, pvmask, zvmask ) 
    1232       CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, pvn, zintv ) 
    1233  
    1234       ! At the end of the day also get interpolated means 
    1235       IF ( idayend == 0 ) THEN 
    1236  
    1237          ALLOCATE( & 
    1238             & zinmu(2,2,kpk,ipro),  & 
    1239             & zinmv(2,2,kpk,ipro)   & 
    1240             & ) 
    1241  
    1242          CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiu, igrdju, & 
    1243             &                  prodatqc%vdmean(:,:,:,1), zinmu ) 
    1244          CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdiv, igrdjv, & 
    1245             &                  prodatqc%vdmean(:,:,:,2), zinmv ) 
    1246  
    1247       ENDIF 
    1248  
    1249 ! loop over observations 
    1250  
    1251       DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
    1252  
    1253          iobs = jobs - prodatqc%nprofup 
    1254  
    1255          IF ( kt /= prodatqc%mstp(jobs) ) THEN 
    1256              
    1257             IF(lwp) THEN 
    1258                WRITE(numout,*) 
    1259                WRITE(numout,*) ' E R R O R : Observation',              & 
    1260                   &            ' time step is not consistent with the', & 
    1261                   &            ' model time step' 
    1262                WRITE(numout,*) ' =========' 
    1263                WRITE(numout,*) 
    1264                WRITE(numout,*) ' Record  = ', jobs,                    & 
    1265                   &            ' kt      = ', kt,                      & 
    1266                   &            ' mstp    = ', prodatqc%mstp(jobs), & 
    1267                   &            ' ntyp    = ', prodatqc%ntyp(jobs) 
    1268             ENDIF 
    1269             CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 
    1270          ENDIF 
    1271           
    1272          zlam = prodatqc%rlam(jobs) 
    1273          zphi = prodatqc%rphi(jobs) 
    1274  
    1275          ! Initialize observation masks 
    1276  
    1277          zobsmasku(:) = 0.0 
    1278          zobsmaskv(:) = 0.0 
    1279           
    1280          ! Horizontal weights and vertical mask 
    1281  
    1282          IF  ( prodatqc%npvend(jobs,1) > 0 ) THEN 
    1283  
    1284             CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi,     & 
    1285                &                   zglamu(:,:,iobs), zgphiu(:,:,iobs), & 
    1286                &                   zumask(:,:,:,iobs), zweigu, zobsmasku ) 
    1287  
    1288          ENDIF 
    1289  
    1290           
    1291          IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
    1292  
    1293             CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi,     & 
    1294                &                   zglamv(:,:,iobs), zgphiv(:,:,iobs), & 
    1295                &                   zvmask(:,:,:,iobs), zweigv, zobsmasku ) 
    1296  
    1297          ENDIF 
    1298  
    1299          ! Ensure that the vertical mask on u and v are consistent. 
    1300  
    1301          zobsmask(:) = MIN( zobsmasku(:), zobsmaskv(:) ) 
    1302  
    1303          IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 
    1304  
    1305             zobsk(:) = obfillflt 
    1306  
    1307        IF ( ld_dailyav ) THEN 
    1308  
    1309                IF ( idayend == 0 )  THEN 
    1310                    
    1311                   ! Daily averaged data 
    1312                    
    1313                   CALL obs_int_h2d( kpk, kpk,      & 
    1314                      &              zweigu, zinmu(:,:,:,iobs), zobsk ) 
    1315                    
    1316                    
    1317                ELSE 
    1318                 
    1319                   CALL ctl_stop( ' A nonzero' //     & 
    1320                      &           ' number of U profile data should' // & 
    1321                      &           ' only occur at the end of a given day' ) 
    1322  
    1323                ENDIF 
    1324            
    1325             ELSE  
    1326                 
    1327                ! Point data 
    1328  
    1329                CALL obs_int_h2d( kpk, kpk,      & 
    1330                   &              zweigu, zintu(:,:,:,iobs), zobsk ) 
    1331  
    1332             ENDIF 
    1333  
    1334             !------------------------------------------------------------- 
    1335             ! Compute vertical second-derivative of the interpolating  
    1336             ! polynomial at obs points 
    1337             !------------------------------------------------------------- 
    1338              
    1339             IF ( k1dint == 1 ) THEN 
    1340                CALL obs_int_z1d_spl( kpk, zobsk, zobs2k,   & 
    1341                   &                  pgdept, zobsmask ) 
    1342             ENDIF 
    1343              
    1344             !----------------------------------------------------------------- 
    1345             !  Vertical interpolation to the observation point 
    1346             !----------------------------------------------------------------- 
    1347             ista = prodatqc%npvsta(jobs,1) 
    1348             iend = prodatqc%npvend(jobs,1) 
    1349             CALL obs_int_z1d( kpk,                & 
    1350                & prodatqc%var(1)%mvk(ista:iend),  & 
    1351                & k1dint, iend - ista + 1,         & 
    1352                & prodatqc%var(1)%vdep(ista:iend), & 
    1353                & zobsk, zobs2k,                   & 
    1354                & prodatqc%var(1)%vmod(ista:iend), & 
    1355                & pgdept, zobsmask ) 
    1356  
    1357          ENDIF 
    1358  
    1359          IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
    1360  
    1361             zobsk(:) = obfillflt 
    1362  
    1363             IF ( ld_dailyav ) THEN 
    1364  
    1365                IF ( idayend == 0 )  THEN 
    1366  
    1367                   ! Daily averaged data 
    1368                    
    1369                   CALL obs_int_h2d( kpk, kpk,      & 
    1370                      &              zweigv, zinmv(:,:,:,iobs), zobsk ) 
    1371                    
    1372                ELSE 
    1373  
    1374                   CALL ctl_stop( ' A nonzero' //     & 
    1375                      &           ' number of V profile data should' // & 
    1376                      &           ' only occur at the end of a given day' ) 
    1377  
    1378                ENDIF 
    1379  
    1380             ELSE 
    1381                 
    1382                ! Point data 
    1383  
    1384                CALL obs_int_h2d( kpk, kpk,      & 
    1385                   &              zweigv, zintv(:,:,:,iobs), zobsk ) 
    1386  
    1387             ENDIF 
    1388  
    1389  
    1390             !------------------------------------------------------------- 
    1391             ! Compute vertical second-derivative of the interpolating  
    1392             ! polynomial at obs points 
    1393             !------------------------------------------------------------- 
    1394              
    1395             IF ( k1dint == 1 ) THEN 
    1396                CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 
    1397                   &                  pgdept, zobsmask ) 
    1398             ENDIF 
    1399              
    1400             !---------------------------------------------------------------- 
    1401             !  Vertical interpolation to the observation point 
    1402             !---------------------------------------------------------------- 
    1403             ista = prodatqc%npvsta(jobs,2) 
    1404             iend = prodatqc%npvend(jobs,2) 
    1405             CALL obs_int_z1d( kpk, & 
    1406                & prodatqc%var(2)%mvk(ista:iend),& 
    1407                & k1dint, iend - ista + 1, & 
    1408                & prodatqc%var(2)%vdep(ista:iend),& 
    1409                & zobsk, zobs2k, & 
    1410                & prodatqc%var(2)%vmod(ista:iend),& 
    1411                & pgdept, zobsmask ) 
    1412  
    1413          ENDIF 
    1414  
    1415       END DO 
    1416   
    1417       ! Deallocate the data for interpolation 
    1418       DEALLOCATE( & 
    1419          & igrdiu, & 
    1420          & igrdju, & 
    1421          & igrdiv, & 
    1422          & igrdjv, & 
    1423          & zglamu, zglamv, & 
    1424          & zgphiu, zgphiv, & 
    1425          & zumask, zvmask, & 
    1426          & zintu, & 
    1427          & zintv  & 
    1428          & ) 
    1429       ! At the end of the day also get interpolated means 
    1430       IF ( idayend == 0 ) THEN 
    1431          DEALLOCATE( & 
    1432             & zinmu,  & 
    1433             & zinmv   & 
    1434             & ) 
    1435       ENDIF 
    1436  
    1437       prodatqc%nprofup = prodatqc%nprofup + ipro  
    1438        
    1439    END SUBROUTINE obs_vel_opt 
     971      ENDIF 
     972 
     973      surfdataqc%nsurfup = surfdataqc%nsurfup + isurf 
     974 
     975   END SUBROUTINE obs_surf_opt 
    1440976 
    1441977END MODULE obs_oper 
    1442  

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

    r8058 r15670  
    77 
    88   !!--------------------------------------------------------------------- 
    9    !!   obs_pre_pro  : First level check and screening of T/S profiles 
    10    !!   obs_pre_sla  : First level check and screening of SLA observations 
    11    !!   obs_pre_sst  : First level check and screening of SLA observations 
    12    !!   obs_pre_seaice : First level check and screening of sea ice observations 
    13    !!   obs_pre_vel  : First level check and screening of velocity obs. 
    14    !!   obs_scr      : Basic screening of the observations 
    15    !!   obs_coo_tim  : Compute number of time steps to the observation time 
    16    !!   obs_sor      : Sort the observation arrays 
     9   !!   obs_pre_prof  : First level check and screening of profile observations 
     10   !!   obs_pre_surf  : First level check and screening of surface observations 
     11   !!   obs_scr       : Basic screening of the observations 
     12   !!   obs_coo_tim   : Compute number of time steps to the observation time 
     13   !!   obs_sor       : Sort the observation arrays 
    1714   !!--------------------------------------------------------------------- 
    1815   !! * Modules used 
    1916   USE par_kind, ONLY : & ! Precision variables 
    2017      & wp    
     18   USE dom_oce            ! ocean space and time domain 
    2119   USE in_out_manager     ! I/O manager 
    2220   USE obs_profiles_def   ! Definitions for storage arrays for profiles 
    … …  
    2725   USE obs_inter_sup      ! Interpolation support 
    2826   USE obs_oper           ! Observation operators 
     27#if defined key_bdy 
     28   USE bdy_oce, ONLY : &        ! Boundary information 
     29      idx_bdy, nb_bdy 
     30#endif 
    2931   USE lib_mpp, ONLY : & 
    3032      & ctl_warn, ctl_stop 
    … …  
    3638 
    3739   PUBLIC & 
    38       & obs_pre_pro, &    ! First level check and screening of profiles 
    39       & obs_pre_sla, &    ! First level check and screening of SLA data 
    40       & obs_pre_sst, &    ! First level check and screening of SLA data 
    41       & obs_pre_seaice, & ! First level check and screening of sea ice data 
    42       & obs_pre_vel, &     ! First level check and screening of velocity profiles 
    43       & calc_month_len     ! Calculate the number of days in the months of a year   
     40      & obs_pre_prof, &    ! First level check and screening of profile obs 
     41      & obs_pre_surf, &    ! First level check and screening of surface obs 
     42      & calc_month_len     ! Calculate the number of days in the months of a year 
    4443 
    4544   !!---------------------------------------------------------------------- 
    … …  
    4948   !!---------------------------------------------------------------------- 
    5049 
     50!! * Substitutions  
     51#  include "domzgr_substitute.h90"   
     52 
    5153CONTAINS 
    5254 
    53    SUBROUTINE obs_pre_pro( profdata, prodatqc, ld_t3d, ld_s3d, ld_nea, & 
    54       &                    kdailyavtypes ) 
    55       !!---------------------------------------------------------------------- 
    56       !!                    ***  ROUTINE obs_pre_pro  *** 
    57       !! 
    58       !! ** Purpose : First level check and screening of T and S profiles 
    59       !! 
    60       !! ** Method  : First level check and screening of T and S profiles 
    61       !! 
    62       !! ** Action  :  
    63       !! 
    64       !! References : 
    65       !!    
    66       !! History : 
    67       !!        !  2007-01  (K. Mogensen) Merge of obs_pre_t3d and obs_pre_s3d  
    68       !!        !  2007-03  (K. Mogensen) General handling of profiles 
    69       !!        !  2007-06  (K. Mogensen et al) Reject obs. near land. 
    70       !!---------------------------------------------------------------------- 
    71       !! * Modules used 
    72       USE domstp              ! Domain: set the time-step 
    73       USE par_oce             ! Ocean parameters 
    74       USE dom_oce, ONLY : &   ! Geographical information 
    75          & glamt,   & 
    76          & gphit,   & 
    77          & gdept_1d,& 
    78          & tmask,   & 
    79          & nproc 
    80       !! * Arguments 
    81       TYPE(obs_prof), INTENT(INOUT) :: profdata     ! Full set of profile data 
    82       TYPE(obs_prof), INTENT(INOUT) :: prodatqc     ! Subset of profile data not failing screening 
    83       LOGICAL, INTENT(IN) :: ld_t3d         ! Switch for temperature 
    84       LOGICAL, INTENT(IN) :: ld_s3d         ! Switch for salinity 
    85       LOGICAL, INTENT(IN) :: ld_nea         ! Switch for rejecting observation near land 
    86       INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    87          & kdailyavtypes! Types for daily averages 
    88       !! * Local declarations    
    89       INTEGER :: iyea0         ! Initial date 
    90       INTEGER :: imon0         !  - (year, month, day, hour, minute) 
    91       INTEGER :: iday0    
    92       INTEGER :: ihou0 
    93       INTEGER :: imin0 
    94       INTEGER :: icycle        ! Current assimilation cycle 
    95                                ! Counters for observations that 
    96       INTEGER :: iotdobs       !  - outside time domain 
    97       INTEGER :: iosdtobs      !  - outside space domain (temperature) 
    98       INTEGER :: iosdsobs      !  - outside space domain (salinity) 
    99       INTEGER :: ilantobs      !  - within a model land cell (temperature) 
    100       INTEGER :: ilansobs      !  - within a model land cell (salinity) 
    101       INTEGER :: inlatobs      !  - close to land (temperature) 
    102       INTEGER :: inlasobs      !  - close to land (salinity) 
    103       INTEGER :: igrdobs       !  - fail the grid search 
    104                                ! Global counters for observations that 
    105       INTEGER :: iotdobsmpp    !  - outside time domain 
    106       INTEGER :: iosdtobsmpp   !  - outside space domain (temperature) 
    107       INTEGER :: iosdsobsmpp   !  - outside space domain (salinity) 
    108       INTEGER :: ilantobsmpp   !  - within a model land cell (temperature) 
    109       INTEGER :: ilansobsmpp   !  - within a model land cell (salinity) 
    110       INTEGER :: inlatobsmpp   !  - close to land (temperature) 
    111       INTEGER :: inlasobsmpp   !  - close to land (salinity) 
    112       INTEGER :: igrdobsmpp    !  - fail the grid search 
    113       TYPE(obs_prof_valid) ::  llvalid     ! Profile selection  
    114       TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    115          & llvvalid            ! T,S selection  
    116       INTEGER :: jvar          ! Variable loop variable 
    117       INTEGER :: jobs          ! Obs. loop variable 
    118       INTEGER :: jstp          ! Time loop variable 
    119       INTEGER :: inrc          ! Time index variable 
    120        
    121       IF(lwp) WRITE(numout,*)'obs_pre_pro : Preparing the profile observations...' 
    122  
    123       ! Initial date initialization (year, month, day, hour, minute) 
    124       iyea0 =   ndate0 / 10000 
    125       imon0 = ( ndate0 - iyea0 * 10000 ) / 100 
    126       iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100 
    127       ihou0 = 0 
    128       imin0 = 0 
    129  
    130       icycle = no     ! Assimilation cycle 
    131  
    132       ! Diagnotics counters for various failures. 
    133  
    134       iotdobs  = 0 
    135       igrdobs  = 0 
    136       iosdtobs = 0 
    137       iosdsobs = 0 
    138       ilantobs = 0 
    139       ilansobs = 0 
    140       inlatobs = 0 
    141       inlasobs = 0 
    142  
    143       ! ----------------------------------------------------------------------- 
    144       ! Find time coordinate for profiles 
    145       ! ----------------------------------------------------------------------- 
    146  
    147       IF ( PRESENT(kdailyavtypes) ) THEN 
    148          CALL obs_coo_tim_prof( icycle, & 
    149             &                iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
    150             &                profdata%nprof,   profdata%nyea, profdata%nmon, & 
    151             &                profdata%nday,    profdata%nhou, profdata%nmin, & 
    152             &                profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
    153             &                iotdobs, kdailyavtypes = kdailyavtypes        ) 
    154       ELSE 
    155          CALL obs_coo_tim_prof( icycle, & 
    156             &                iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
    157             &                profdata%nprof,   profdata%nyea, profdata%nmon, & 
    158             &                profdata%nday,    profdata%nhou, profdata%nmin, & 
    159             &                profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
    160             &                iotdobs ) 
    161       ENDIF 
    162       CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    163        
    164       ! ----------------------------------------------------------------------- 
    165       ! Check for profiles failing the grid search 
    166       ! ----------------------------------------------------------------------- 
    167  
    168       CALL obs_coo_grd( profdata%nprof,   profdata%mi, profdata%mj, & 
    169          &              profdata%nqc,     igrdobs                         ) 
    170  
    171       CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    172  
    173       ! ----------------------------------------------------------------------- 
    174       ! Reject all observations for profiles with nqc > 10 
    175       ! ----------------------------------------------------------------------- 
    176  
    177       CALL obs_pro_rej( profdata ) 
    178  
    179       ! ----------------------------------------------------------------------- 
    180       ! Check for land points. This includes points below the model 
    181       ! bathymetry so this is done for every point in the profile 
    182       ! ----------------------------------------------------------------------- 
    183  
    184       ! Temperature 
    185  
    186       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    187          &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    188          &                 jpi,                   jpj,                  & 
    189          &                 jpk,                                         & 
    190          &                 profdata%mi,           profdata%mj,          &  
    191          &                 profdata%var(1)%mvk,                         & 
    192          &                 profdata%rlam,         profdata%rphi,        & 
    193          &                 profdata%var(1)%vdep,                        & 
    194          &                 glamt,                 gphit,                & 
    195          &                 gdept_1d,              tmask,                & 
    196          &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    197          &                 iosdtobs,              ilantobs,             & 
    198          &                 inlatobs,              ld_nea                ) 
    199  
    200       CALL obs_mpp_sum_integer( iosdtobs, iosdtobsmpp ) 
    201       CALL obs_mpp_sum_integer( ilantobs, ilantobsmpp ) 
    202       CALL obs_mpp_sum_integer( inlatobs, inlatobsmpp ) 
    203  
    204       ! Salinity 
    205  
    206       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    207          &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    208          &                 jpi,                   jpj,                  & 
    209          &                 jpk,                                         & 
    210          &                 profdata%mi,           profdata%mj,          &  
    211          &                 profdata%var(2)%mvk,                         & 
    212          &                 profdata%rlam,         profdata%rphi,        & 
    213          &                 profdata%var(2)%vdep,                        & 
    214          &                 glamt,                 gphit,                & 
    215          &                 gdept_1d,              tmask,                & 
    216          &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    217          &                 iosdsobs,              ilansobs,             & 
    218          &                 inlasobs,              ld_nea                ) 
    219  
    220       CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    221       CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    222       CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
    223  
    224       ! ----------------------------------------------------------------------- 
    225       ! Copy useful data from the profdata data structure to 
    226       ! the prodatqc data structure  
    227       ! ----------------------------------------------------------------------- 
    228  
    229       ! Allocate the selection arrays 
    230  
    231       ALLOCATE( llvalid%luse(profdata%nprof) ) 
    232       DO jvar = 1,profdata%nvar 
    233          ALLOCATE( llvvalid(jvar)%luse(profdata%nvprot(jvar)) ) 
    234       END DO 
    235  
    236       ! We want all data which has qc flags <= 10 
    237  
    238       llvalid%luse(:) = ( profdata%nqc(:)  <= 10 ) 
    239       DO jvar = 1,profdata%nvar 
    240          llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10 ) 
    241       END DO 
    242  
    243       ! The actual copying 
    244  
    245       CALL obs_prof_compress( profdata,     prodatqc,       .TRUE.,  numout, & 
    246          &                    lvalid=llvalid, lvvalid=llvvalid ) 
    247  
    248       ! Dellocate the selection arrays 
    249       DEALLOCATE( llvalid%luse ) 
    250       DO jvar = 1,profdata%nvar 
    251          DEALLOCATE( llvvalid(jvar)%luse ) 
    252       END DO 
    253  
    254       ! ----------------------------------------------------------------------- 
    255       ! Print information about what observations are left after qc 
    256       ! ----------------------------------------------------------------------- 
    257  
    258       ! Update the total observation counter array 
    259        
    260       IF(lwp) THEN 
    261          WRITE(numout,*) 
    262          WRITE(numout,*) 'obs_pre_pro :' 
    263          WRITE(numout,*) '~~~~~~~~~~~' 
    264          WRITE(numout,*) 
    265          WRITE(numout,*) ' Profiles outside time domain                = ', & 
    266             &            iotdobsmpp 
    267          WRITE(numout,*) ' Remaining profiles that failed grid search  = ', & 
    268             &            igrdobsmpp 
    269          WRITE(numout,*) ' Remaining T data outside space domain       = ', & 
    270             &            iosdtobsmpp 
    271          WRITE(numout,*) ' Remaining T data at land points             = ', & 
    272             &            ilantobsmpp 
    273          IF (ld_nea) THEN 
    274             WRITE(numout,*) ' Remaining T data near land points (removed) = ',& 
    275                &            inlatobsmpp 
    276          ELSE 
    277             WRITE(numout,*) ' Remaining T data near land points (kept)    = ',& 
    278                &            inlatobsmpp 
    279          ENDIF 
    280          WRITE(numout,*) ' T data accepted                             = ', & 
    281             &            prodatqc%nvprotmpp(1) 
    282          WRITE(numout,*) ' Remaining S data outside space domain       = ', & 
    283             &            iosdsobsmpp 
    284          WRITE(numout,*) ' Remaining S data at land points             = ', & 
    285             &            ilansobsmpp 
    286          IF (ld_nea) THEN 
    287             WRITE(numout,*) ' Remaining S data near land points (removed) = ',& 
    288                &            inlasobsmpp 
    289          ELSE 
    290             WRITE(numout,*) ' Remaining S data near land points (kept)    = ',& 
    291                &            inlasobsmpp 
    292          ENDIF 
    293          WRITE(numout,*) ' S data accepted                             = ', & 
    294             &            prodatqc%nvprotmpp(2) 
    295  
    296          WRITE(numout,*) 
    297          WRITE(numout,*) ' Number of observations per time step :' 
    298          WRITE(numout,*) 
    299          WRITE(numout,997) 
    300          WRITE(numout,998) 
    301       ENDIF 
    302        
    303       DO jobs = 1, prodatqc%nprof 
    304          inrc = prodatqc%mstp(jobs) + 2 - nit000 
    305          prodatqc%npstp(inrc)  = prodatqc%npstp(inrc) + 1 
    306          DO jvar = 1, prodatqc%nvar 
    307             IF ( prodatqc%npvend(jobs,jvar) > 0 ) THEN 
    308                prodatqc%nvstp(inrc,jvar) = prodatqc%nvstp(inrc,jvar) + & 
    309                   &                      ( prodatqc%npvend(jobs,jvar) - & 
    310                   &                        prodatqc%npvsta(jobs,jvar) + 1 ) 
    311             ENDIF 
    312          END DO 
    313       END DO 
    314        
    315        
    316       CALL obs_mpp_sum_integers( prodatqc%npstp, prodatqc%npstpmpp, & 
    317          &                       nitend - nit000 + 2 ) 
    318       DO jvar = 1, prodatqc%nvar 
    319          CALL obs_mpp_sum_integers( prodatqc%nvstp(:,jvar), & 
    320             &                       prodatqc%nvstpmpp(:,jvar), & 
    321             &                       nitend - nit000 + 2 ) 
    322       END DO 
    323  
    324       IF ( lwp ) THEN 
    325          DO jstp = nit000 - 1, nitend 
    326             inrc = jstp - nit000 + 2 
    327             WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    328                &                    prodatqc%nvstpmpp(inrc,1), & 
    329                &                    prodatqc%nvstpmpp(inrc,2) 
    330          END DO 
    331       ENDIF 
    332  
    333 997   FORMAT(10X,'Time step',5X,'Profiles',5X,'Temperature',5X,'Salinity') 
    334 998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'--------') 
    335 999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    336        
    337    END SUBROUTINE obs_pre_pro 
    338  
    339    SUBROUTINE obs_pre_sla( sladata, sladatqc, ld_sla, ld_nea ) 
     55   SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea, ld_bound_reject, & 
     56                            kqc_cutoff ) 
    34057      !!---------------------------------------------------------------------- 
    34158      !!                    ***  ROUTINE obs_pre_sla  *** 
    34259      !! 
    343       !! ** Purpose : First level check and screening of SLA observations 
    344       !! 
    345       !! ** Method  : First level check and screening of SLA observations 
     60      !! ** Purpose : First level check and screening of surface observations 
     61      !! 
     62      !! ** Method  : First level check and screening of surface observations 
    34663      !! 
    34764      !! ** Action  :  
    … …  
    35269      !!        !  2007-03  (A. Weaver, K. Mogensen) Original 
    35370      !!        !  2007-06  (K. Mogensen et al) Reject obs. near land. 
     71      !!        !  2015-02  (M. Martin) Combined routine for surface types. 
    35472      !!---------------------------------------------------------------------- 
    35573      !! * Modules used 
    … …  
    36280         & nproc 
    36381      !! * Arguments 
    364       TYPE(obs_surf), INTENT(INOUT) :: sladata    ! Full set of SLA data 
    365       TYPE(obs_surf), INTENT(INOUT) :: sladatqc   ! Subset of SLA data not failing screening 
    366       LOGICAL, INTENT(IN) :: ld_sla         ! Switch for SLA data 
    367       LOGICAL, INTENT(IN) :: ld_nea         ! Switch for rejecting observation near land 
     82      TYPE(obs_surf), INTENT(INOUT) :: surfdata    ! Full set of surface data 
     83      TYPE(obs_surf), INTENT(INOUT) :: surfdataqc  ! Subset of surface data not failing screening 
     84      LOGICAL, INTENT(IN) :: ld_nea                ! Switch for rejecting observation near land 
     85      LOGICAL, INTENT(IN) :: ld_bound_reject       ! Switch for rejecting obs near the boundary 
     86      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value 
    36887      !! * Local declarations 
     88      INTEGER :: iqc_cutoff = 255   ! cut off for QC value 
    36989      INTEGER :: iyea0        ! Initial date 
    37090      INTEGER :: imon0        !  - (year, month, day, hour, minute) 
    … …  
    37999      INTEGER :: inlasobs     !  - close to land 
    380100      INTEGER :: igrdobs      !  - fail the grid search 
     101      INTEGER :: ibdysobs     !  - close to open boundary 
    381102                              ! Global counters for observations that 
    382103      INTEGER :: iotdobsmpp     !  - outside time domain 
    … …  
    385106      INTEGER :: inlasobsmpp    !  - close to land 
    386107      INTEGER :: igrdobsmpp     !  - fail the grid search 
     108      INTEGER :: ibdysobsmpp  !  - close to open boundary 
    387109      LOGICAL, DIMENSION(:), ALLOCATABLE :: &  
    388110         & llvalid            ! SLA data selection 
    … …  
    391113      INTEGER :: inrc         ! Time index variable 
    392114 
    393       IF(lwp) WRITE(numout,*)'obs_pre_sla : Preparing the SLA observations...' 
    394  
     115      IF(lwp) WRITE(numout,*)'obs_pre_surf : Preparing the surface observations...' 
     116      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     117       
    395118      ! Initial date initialization (year, month, day, hour, minute) 
    396119      iyea0 =   ndate0 / 10000 
    … …  
    409132      ilansobs = 0 
    410133      inlasobs = 0 
    411  
    412       ! ----------------------------------------------------------------------- 
    413       ! Find time coordinate for SLA data 
     134      ibdysobs = 0  
     135 
     136      ! Set QC cutoff to optional value if provided 
     137      IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 
     138 
     139      ! ----------------------------------------------------------------------- 
     140      ! Find time coordinate for surface data 
    414141      ! ----------------------------------------------------------------------- 
    415142 
    416143      CALL obs_coo_tim( icycle, & 
    417144         &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
    418          &              sladata%nsurf,   sladata%nyea, sladata%nmon, & 
    419          &              sladata%nday,    sladata%nhou, sladata%nmin, & 
    420          &              sladata%nqc,     sladata%mstp, iotdobs        ) 
     145         &              surfdata%nsurf,   surfdata%nyea, surfdata%nmon, & 
     146         &              surfdata%nday,    surfdata%nhou, surfdata%nmin, & 
     147         &              surfdata%nqc,     surfdata%mstp, iotdobs        ) 
    421148 
    422149      CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    423150       
    424151      ! ----------------------------------------------------------------------- 
    425       ! Check for SLA data failing the grid search 
    426       ! ----------------------------------------------------------------------- 
    427  
    428       CALL obs_coo_grd( sladata%nsurf,   sladata%mi, sladata%mj, & 
    429          &              sladata%nqc,     igrdobs                         ) 
     152      ! Check for surface data failing the grid search 
     153      ! ----------------------------------------------------------------------- 
     154 
     155      CALL obs_coo_grd( surfdata%nsurf,   surfdata%mi, surfdata%mj, & 
     156         &              surfdata%nqc,     igrdobs                         ) 
    430157 
    431158      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    … …  
    435162      ! ----------------------------------------------------------------------- 
    436163 
    437       CALL obs_coo_spc_2d( sladata%nsurf,              & 
     164      CALL obs_coo_spc_2d( surfdata%nsurf,              & 
    438165         &                 jpi,          jpj,          & 
    439          &                 sladata%mi,   sladata%mj,   &  
    440          &                 sladata%rlam, sladata%rphi, & 
     166         &                 surfdata%mi,   surfdata%mj,   &  
     167         &                 surfdata%rlam, surfdata%rphi, & 
    441168         &                 glamt,        gphit,        & 
    442          &                 tmask(:,:,1), sladata%nqc,  & 
     169         &                 tmask(:,:,1), surfdata%nqc,  & 
    443170         &                 iosdsobs,     ilansobs,     & 
    444          &                 inlasobs,     ld_nea        ) 
     171         &                 inlasobs,     ld_nea,       & 
     172         &                 ibdysobs,     ld_bound_reject, & 
     173         &                 iqc_cutoff                     ) 
    445174 
    446175      CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    447176      CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    448177      CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
    449  
    450       ! ----------------------------------------------------------------------- 
    451       ! Copy useful data from the sladata data structure to 
    452       ! the sladatqc data structure  
     178      CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp ) 
     179 
     180      ! ----------------------------------------------------------------------- 
     181      ! Copy useful data from the surfdata data structure to 
     182      ! the surfdataqc data structure  
    453183      ! ----------------------------------------------------------------------- 
    454184 
    455185      ! Allocate the selection arrays 
    456186 
    457       ALLOCATE( llvalid(sladata%nsurf) ) 
    458        
    459       ! We want all data which has qc flags <= 10 
    460  
    461       llvalid(:)  = ( sladata%nqc(:)  <= 10 ) 
     187      ALLOCATE( llvalid(surfdata%nsurf) ) 
     188       
     189      ! We want all data which has qc flags <= iqc_cutoff 
     190 
     191      llvalid(:)  = ( surfdata%nqc(:)  <= iqc_cutoff ) 
    462192 
    463193      ! The actual copying 
    464194 
    465       CALL obs_surf_compress( sladata,     sladatqc,       .TRUE.,  numout, & 
     195      CALL obs_surf_compress( surfdata,     surfdataqc,       .TRUE.,  numout, & 
    466196         &                    lvalid=llvalid ) 
    467197 
    … …  
    477207      IF(lwp) THEN 
    478208         WRITE(numout,*) 
    479          WRITE(numout,*) 'obs_pre_sla :' 
    480          WRITE(numout,*) '~~~~~~~~~~~' 
    481          WRITE(numout,*) 
    482          WRITE(numout,*) ' SLA data outside time domain                  = ', & 
     209         WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain                  = ', & 
    483210            &            iotdobsmpp 
    484          WRITE(numout,*) ' Remaining SLA data that failed grid search    = ', & 
     211         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search    = ', & 
    485212            &            igrdobsmpp 
    486          WRITE(numout,*) ' Remaining SLA data outside space domain       = ', & 
     213         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain       = ', & 
    487214            &            iosdsobsmpp 
    488          WRITE(numout,*) ' Remaining SLA data at land points             = ', & 
     215         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points             = ', & 
    489216            &            ilansobsmpp 
    490217         IF (ld_nea) THEN 
    491             WRITE(numout,*) ' Remaining SLA data near land points (removed) = ', & 
     218            WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & 
    492219               &            inlasobsmpp 
    493220         ELSE 
    494             WRITE(numout,*) ' Remaining SLA data near land points (kept)    = ', & 
     221            WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept)    = ', & 
    495222               &            inlasobsmpp 
    496223         ENDIF 
    497          WRITE(numout,*) ' SLA data accepted                             = ', & 
    498             &            sladatqc%nsurfmpp 
     224         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near open boundary (removed) = ', & 
     225            &            ibdysobsmpp   
     226         WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted                             = ', & 
     227            &            surfdataqc%nsurfmpp 
    499228 
    500229         WRITE(numout,*) 
    501230         WRITE(numout,*) ' Number of observations per time step :' 
    502231         WRITE(numout,*) 
    503          WRITE(numout,1997) 
    504          WRITE(numout,1998) 
     232         WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1) 
     233         WRITE(numout,'(10X,A,5X,A)')'---------','-----------------' 
     234         CALL FLUSH(numout) 
    505235      ENDIF 
    506236       
    507       DO jobs = 1, sladatqc%nsurf 
    508          inrc = sladatqc%mstp(jobs) + 2 - nit000 
    509          sladatqc%nsstp(inrc)  = sladatqc%nsstp(inrc) + 1 
    510       END DO 
    511        
    512       CALL obs_mpp_sum_integers( sladatqc%nsstp, sladatqc%nsstpmpp, & 
     237      DO jobs = 1, surfdataqc%nsurf 
     238         inrc = surfdataqc%mstp(jobs) + 2 - nit000 
     239         surfdataqc%nsstp(inrc)  = surfdataqc%nsstp(inrc) + 1 
     240      END DO 
     241       
     242      CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, & 
    513243         &                       nitend - nit000 + 2 ) 
    514244 
    … …  
    516246         DO jstp = nit000 - 1, nitend 
    517247            inrc = jstp - nit000 + 2 
    518             WRITE(numout,1999) jstp, sladatqc%nsstpmpp(inrc) 
     248            WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc) 
     249            CALL FLUSH(numout) 
    519250         END DO 
    520251      ENDIF 
    521252 
    522 1997  FORMAT(10X,'Time step',5X,'Sea level anomaly') 
    523 1998  FORMAT(10X,'---------',5X,'-----------------') 
    5242531999  FORMAT(10X,I9,5X,I17) 
    525254 
    526    END SUBROUTINE obs_pre_sla 
    527  
    528    SUBROUTINE obs_pre_sst( sstdata, sstdatqc, ld_sst, ld_nea ) 
    529       !!---------------------------------------------------------------------- 
    530       !!                    ***  ROUTINE obs_pre_sst  *** 
    531       !! 
    532       !! ** Purpose : First level check and screening of SST observations 
    533       !! 
    534       !! ** Method  : First level check and screening of SST observations 
    535       !! 
    536       !! ** Action  :  
    537       !! 
    538       !! References : 
    539       !!    
     255   END SUBROUTINE obs_pre_surf 
     256 
     257 
     258   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 
     259      &                     kpi, kpj, kpk, & 
     260      &                     zmask, pglam, pgphi,  & 
     261      &                     ld_nea, ld_bound_reject, kdailyavtypes,  kqc_cutoff ) 
     262 
     263!!---------------------------------------------------------------------- 
     264      !!                    ***  ROUTINE obs_pre_prof  *** 
     265      !! 
     266      !! ** Purpose : First level check and screening of profiles 
     267      !! 
     268      !! ** Method  : First level check and screening of profiles 
     269      !! 
    540270      !! History : 
    541       !!        !  2007-03  (S. Ricci) SST data preparation  
     271      !!        !  2007-06  (K. Mogensen) original : T and S profile data 
     272      !!        !  2008-09  (M. Valdivieso) : TAO velocity data 
     273      !!        !  2009-01  (K. Mogensen) : New feedback stricture 
     274      !!        !  2015-02  (M. Martin) : Combined profile routine. 
     275      !! 
    542276      !!---------------------------------------------------------------------- 
    543277      !! * Modules used 
    … …  
    545279      USE par_oce             ! Ocean parameters 
    546280      USE dom_oce, ONLY : &   ! Geographical information 
    547          & glamt,   & 
    548          & gphit,   & 
    549          & tmask,   & 
     281         & gdept_1d,             & 
    550282         & nproc 
     283 
    551284      !! * Arguments 
    552       TYPE(obs_surf), INTENT(INOUT) :: sstdata     ! Full set of SST data 
    553       TYPE(obs_surf), INTENT(INOUT) :: sstdatqc    ! Subset of SST data not failing screening 
    554       LOGICAL :: ld_sst             ! Switch for SST data 
    555       LOGICAL :: ld_nea             ! Switch for rejecting observation near land 
     285      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
     286      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening 
     287      LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 
     288         & ld_var                                 ! Observed variables switches 
     289      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land 
     290      LOGICAL, INTENT(IN) :: ld_bound_reject      ! Switch for rejecting observations near the boundary 
     291      INTEGER, INTENT(IN) :: kpi, kpj, kpk        ! Local domain sizes 
     292      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
     293         & kdailyavtypes                          ! Types for daily averages 
     294      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 
     295         & zmask 
     296      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 
     297         & pglam, & 
     298         & pgphi 
     299      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value 
     300 
    556301      !! * Local declarations 
     302      INTEGER :: iqc_cutoff = 255   ! cut off for QC value 
    557303      INTEGER :: iyea0        ! Initial date 
    558304      INTEGER :: imon0        !  - (year, month, day, hour, minute) 
    559       INTEGER :: iday0    
     305      INTEGER :: iday0     
    560306      INTEGER :: ihou0     
    561307      INTEGER :: imin0 
    562308      INTEGER :: icycle       ! Current assimilation cycle 
    563                               ! Counters for observations that 
    564       INTEGER :: iotdobs      !  - outside time domain 
    565       INTEGER :: iosdsobs     !  - outside space domain 
    566       INTEGER :: ilansobs     !  - within a model land cell 
    567       INTEGER :: inlasobs     !  - close to land 
    568       INTEGER :: igrdobs      !  - fail the grid search 
    569                               ! Global counters for observations that 
    570       INTEGER :: iotdobsmpp   !  - outside time domain 
    571       INTEGER :: iosdsobsmpp  !  - outside space domain 
    572       INTEGER :: ilansobsmpp  !  - within a model land cell 
    573       INTEGER :: inlasobsmpp  !  - close to land 
    574       INTEGER :: igrdobsmpp   !  - fail the grid search 
    575       LOGICAL, DIMENSION(:), ALLOCATABLE :: &  
    576          & llvalid            ! SST data selection 
     309                                                       ! Counters for observations that are 
     310      INTEGER                           :: iotdobs     !  - outside time domain 
     311      INTEGER, DIMENSION(profdata%nvar) :: iosdvobs    !  - outside space domain 
     312      INTEGER, DIMENSION(profdata%nvar) :: ilanvobs    !  - within a model land cell 
     313      INTEGER, DIMENSION(profdata%nvar) :: inlavobs    !  - close to land 
     314      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs    !  - boundary    
     315      INTEGER                           :: igrdobs     !  - fail the grid search 
     316      INTEGER                           :: iuvchku     !  - reject UVEL if VVEL rejected 
     317      INTEGER                           :: iuvchkv     !  - reject VVEL if UVEL rejected 
     318                                                       ! Global counters for observations that are 
     319      INTEGER                           :: iotdobsmpp  !  - outside time domain 
     320      INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp !  - outside space domain 
     321      INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp !  - within a model land cell 
     322      INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp !  - close to land 
     323      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp !  - boundary 
     324      INTEGER :: igrdobsmpp                            !  - fail the grid search 
     325      INTEGER :: iuvchkumpp                            !  - reject UVEL if VVEL rejected 
     326      INTEGER :: iuvchkvmpp                            !  - reject VVEL if UVEL rejected 
     327      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
     328      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
     329         & llvvalid           ! vars selection  
     330      INTEGER :: jvar         ! Variable loop variable 
    577331      INTEGER :: jobs         ! Obs. loop variable 
    578332      INTEGER :: jstp         ! Time loop variable 
    579333      INTEGER :: inrc         ! Time index variable 
    580  
    581       IF(lwp) WRITE(numout,*)'obs_pre_sst : Preparing the SST observations...' 
     334      CHARACTER(LEN=256) :: cout1  ! Diagnostic output line 
     335      CHARACTER(LEN=256) :: cout2  ! Diagnostic output line 
     336 
     337      IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' 
     338      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    582339 
    583340      ! Initial date initialization (year, month, day, hour, minute) 
    … …  
    590347      icycle = no     ! Assimilation cycle 
    591348 
    592       ! Diagnotics counters for various failures. 
    593  
    594       iotdobs  = 0 
    595       igrdobs  = 0 
    596       iosdsobs = 0 
    597       ilansobs = 0 
    598       inlasobs = 0 
    599  
    600       ! ----------------------------------------------------------------------- 
    601       ! Find time coordinate for SST data 
    602       ! ----------------------------------------------------------------------- 
    603  
    604       CALL obs_coo_tim( icycle, & 
    605          &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
    606          &              sstdata%nsurf,   sstdata%nyea, sstdata%nmon, & 
    607          &              sstdata%nday,    sstdata%nhou, sstdata%nmin, & 
    608          &              sstdata%nqc,     sstdata%mstp, iotdobs        ) 
     349      ! Diagnostics counters for various failures. 
     350 
     351      iotdobs     = 0 
     352      igrdobs     = 0 
     353      iosdvobs(:) = 0 
     354      ilanvobs(:) = 0 
     355      inlavobs(:) = 0 
     356      ibdyvobs(:) = 0 
     357      iuvchku     = 0 
     358      iuvchkv     = 0 
     359 
     360 
     361      ! Set QC cutoff to optional value if provided 
     362      IF ( PRESENT(kqc_cutoff) ) iqc_cutoff=kqc_cutoff 
     363 
     364      ! ----------------------------------------------------------------------- 
     365      ! Find time coordinate for profiles 
     366      ! ----------------------------------------------------------------------- 
     367 
     368      IF ( PRESENT(kdailyavtypes) ) THEN 
     369         CALL obs_coo_tim_prof( icycle, & 
     370            &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
     371            &              profdata%nprof,   profdata%nyea, profdata%nmon, & 
     372            &              profdata%nday,    profdata%nhou, profdata%nmin, & 
     373            &              profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
     374            &              iotdobs, kdailyavtypes = kdailyavtypes,         & 
     375            &              kqc_cutoff = iqc_cutoff ) 
     376      ELSE 
     377         CALL obs_coo_tim_prof( icycle, & 
     378            &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
     379            &              profdata%nprof,   profdata%nyea, profdata%nmon, & 
     380            &              profdata%nday,    profdata%nhou, profdata%nmin, & 
     381            &              profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
     382            &              iotdobs,          kqc_cutoff = iqc_cutoff ) 
     383      ENDIF 
     384 
    609385      CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    610       ! ----------------------------------------------------------------------- 
    611       ! Check for SST data failing the grid search 
    612       ! ----------------------------------------------------------------------- 
    613  
    614       CALL obs_coo_grd( sstdata%nsurf,   sstdata%mi, sstdata%mj, & 
    615          &              sstdata%nqc,     igrdobs                         ) 
     386       
     387      ! ----------------------------------------------------------------------- 
     388      ! Check for profiles failing the grid search 
     389      ! ----------------------------------------------------------------------- 
     390 
     391      DO jvar = 1, profdata%nvar 
     392         CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,jvar), profdata%mj(:,jvar), & 
     393            &              profdata%nqc,     igrdobs ) 
     394      END DO 
     395 
    616396      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    617397 
    618398      ! ----------------------------------------------------------------------- 
    619       ! Check for land points.  
    620       ! ----------------------------------------------------------------------- 
    621  
    622       CALL obs_coo_spc_2d( sstdata%nsurf,              & 
    623          &                 jpi,          jpj,          & 
    624          &                 sstdata%mi,   sstdata%mj,   &  
    625          &                 sstdata%rlam, sstdata%rphi, & 
    626          &                 glamt,        gphit,        & 
    627          &                 tmask(:,:,1), sstdata%nqc,  & 
    628          &                 iosdsobs,     ilansobs,     & 
    629          &                 inlasobs,     ld_nea        ) 
    630  
    631       CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    632       CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    633       CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
    634  
    635       ! ----------------------------------------------------------------------- 
    636       ! Copy useful data from the sstdata data structure to 
    637       ! the sstdatqc data structure  
    638       ! ----------------------------------------------------------------------- 
    639  
    640       ! Allocate the selection arrays 
    641  
    642       ALLOCATE( llvalid(sstdata%nsurf) ) 
    643        
    644       ! We want all data which has qc flags <= 0 
    645  
    646       llvalid(:)  = ( sstdata%nqc(:)  <= 10 ) 
    647  
    648       ! The actual copying 
    649  
    650       CALL obs_surf_compress( sstdata,     sstdatqc,       .TRUE.,  numout, & 
    651          &                    lvalid=llvalid ) 
    652  
    653       ! Dellocate the selection arrays 
    654       DEALLOCATE( llvalid ) 
    655  
    656       ! ----------------------------------------------------------------------- 
    657       ! Print information about what observations are left after qc 
    658       ! ----------------------------------------------------------------------- 
    659  
    660       ! Update the total observation counter array 
    661        
    662       IF(lwp) THEN 
    663          WRITE(numout,*) 
    664          WRITE(numout,*) 'obs_pre_sst :' 
    665          WRITE(numout,*) '~~~~~~~~~~~' 
    666          WRITE(numout,*) 
    667          WRITE(numout,*) ' SST data outside time domain                  = ', & 
    668             &            iotdobsmpp 
    669          WRITE(numout,*) ' Remaining SST data that failed grid search    = ', & 
    670             &            igrdobsmpp 
    671          WRITE(numout,*) ' Remaining SST data outside space domain       = ', & 
    672             &            iosdsobsmpp 
    673          WRITE(numout,*) ' Remaining SST data at land points             = ', & 
    674             &            ilansobsmpp 
    675          IF (ld_nea) THEN 
    676             WRITE(numout,*) ' Remaining SST data near land points (removed) = ', & 
    677                &            inlasobsmpp 
    678          ELSE 
    679             WRITE(numout,*) ' Remaining SST data near land points (kept)    = ', & 
    680                &            inlasobsmpp 
    681          ENDIF 
    682          WRITE(numout,*) ' SST data accepted                             = ', & 
    683             &            sstdatqc%nsurfmpp 
    684  
    685          WRITE(numout,*) 
    686          WRITE(numout,*) ' Number of observations per time step :' 
    687          WRITE(numout,*) 
    688          WRITE(numout,1997) 
    689          WRITE(numout,1998) 
    690       ENDIF 
    691        
    692       DO jobs = 1, sstdatqc%nsurf 
    693          inrc = sstdatqc%mstp(jobs) + 2 - nit000 
    694          sstdatqc%nsstp(inrc)  = sstdatqc%nsstp(inrc) + 1 
    695       END DO 
    696        
    697       CALL obs_mpp_sum_integers( sstdatqc%nsstp, sstdatqc%nsstpmpp, & 
    698          &                       nitend - nit000 + 2 ) 
    699  
    700       IF ( lwp ) THEN 
    701          DO jstp = nit000 - 1, nitend 
    702             inrc = jstp - nit000 + 2 
    703             WRITE(numout,1999) jstp, sstdatqc%nsstpmpp(inrc) 
    704          END DO 
    705       ENDIF 
    706  
    707 1997  FORMAT(10X,'Time step',5X,'Sea surface temperature') 
    708 1998  FORMAT(10X,'---------',5X,'-----------------') 
    709 1999  FORMAT(10X,I9,5X,I17) 
    710        
    711    END SUBROUTINE obs_pre_sst 
    712  
    713    SUBROUTINE obs_pre_seaice( seaicedata, seaicedatqc, ld_seaice, ld_nea ) 
    714       !!---------------------------------------------------------------------- 
    715       !!                    ***  ROUTINE obs_pre_seaice  *** 
    716       !! 
    717       !! ** Purpose : First level check and screening of Sea Ice observations 
    718       !! 
    719       !! ** Method  : First level check and screening of Sea Ice observations 
    720       !! 
    721       !! ** Action  :  
    722       !! 
    723       !! References : 
    724       !!    
    725       !! History : 
    726       !!        !  2007-11 (D. Lea) based on obs_pre_sst 
    727       !!---------------------------------------------------------------------- 
    728       !! * Modules used 
    729       USE domstp              ! Domain: set the time-step 
    730       USE par_oce             ! Ocean parameters 
    731       USE dom_oce, ONLY : &   ! Geographical information 
    732          & glamt,   & 
    733          & gphit,   & 
    734          & tmask,   & 
    735          & nproc 
    736       !! * Arguments 
    737       TYPE(obs_surf), INTENT(INOUT) :: seaicedata     ! Full set of Sea Ice data 
    738       TYPE(obs_surf), INTENT(INOUT) :: seaicedatqc    ! Subset of sea ice data not failing screening 
    739       LOGICAL :: ld_seaice     ! Switch for sea ice data 
    740       LOGICAL :: ld_nea        ! Switch for rejecting observation near land 
    741       !! * Local declarations 
    742       INTEGER :: iyea0         ! Initial date 
    743       INTEGER :: imon0         !  - (year, month, day, hour, minute) 
    744       INTEGER :: iday0     
    745       INTEGER :: ihou0     
    746       INTEGER :: imin0 
    747       INTEGER :: icycle       ! Current assimilation cycle 
    748                               ! Counters for observations that 
    749       INTEGER :: iotdobs      !  - outside time domain 
    750       INTEGER :: iosdsobs     !  - outside space domain 
    751       INTEGER :: ilansobs     !  - within a model land cell 
    752       INTEGER :: inlasobs     !  - close to land 
    753       INTEGER :: igrdobs      !  - fail the grid search 
    754                               ! Global counters for observations that 
    755       INTEGER :: iotdobsmpp   !  - outside time domain 
    756       INTEGER :: iosdsobsmpp  !  - outside space domain 
    757       INTEGER :: ilansobsmpp  !  - within a model land cell 
    758       INTEGER :: inlasobsmpp  !  - close to land 
    759       INTEGER :: igrdobsmpp   !  - fail the grid search 
    760       LOGICAL, DIMENSION(:), ALLOCATABLE :: &  
    761          & llvalid            ! data selection 
    762       INTEGER :: jobs         ! Obs. loop variable 
    763       INTEGER :: jstp         ! Time loop variable 
    764       INTEGER :: inrc         ! Time index variable 
    765  
    766       IF (lwp) WRITE(numout,*)'obs_pre_seaice : Preparing the sea ice observations...' 
    767  
    768       ! Initial date initialization (year, month, day, hour, minute) 
    769       iyea0 =   ndate0 / 10000 
    770       imon0 = ( ndate0 - iyea0 * 10000 ) / 100 
    771       iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100 
    772       ihou0 = 0 
    773       imin0 = 0 
    774  
    775       icycle = no     ! Assimilation cycle 
    776  
    777       ! Diagnotics counters for various failures. 
    778  
    779       iotdobs  = 0 
    780       igrdobs  = 0 
    781       iosdsobs = 0 
    782       ilansobs = 0 
    783       inlasobs = 0 
    784  
    785       ! ----------------------------------------------------------------------- 
    786       ! Find time coordinate for sea ice data 
    787       ! ----------------------------------------------------------------------- 
    788  
    789       CALL obs_coo_tim( icycle, & 
    790          &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
    791          &              seaicedata%nsurf,   seaicedata%nyea, seaicedata%nmon, & 
    792          &              seaicedata%nday,    seaicedata%nhou, seaicedata%nmin, & 
    793          &              seaicedata%nqc,     seaicedata%mstp, iotdobs        ) 
    794       CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    795       ! ----------------------------------------------------------------------- 
    796       ! Check for sea ice data failing the grid search 
    797       ! ----------------------------------------------------------------------- 
    798  
    799       CALL obs_coo_grd( seaicedata%nsurf,   seaicedata%mi, seaicedata%mj, & 
    800          &              seaicedata%nqc,     igrdobs                         ) 
    801       CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    802  
    803       ! ----------------------------------------------------------------------- 
    804       ! Check for land points.  
    805       ! ----------------------------------------------------------------------- 
    806  
    807       CALL obs_coo_spc_2d( seaicedata%nsurf,                 & 
    808          &                 jpi,             jpj,             & 
    809          &                 seaicedata%mi,   seaicedata%mj,   &  
    810          &                 seaicedata%rlam, seaicedata%rphi, & 
    811          &                 glamt,           gphit,           & 
    812          &                 tmask(:,:,1),    seaicedata%nqc,  & 
    813          &                 iosdsobs,        ilansobs,        & 
    814          &                 inlasobs,        ld_nea           ) 
    815  
    816       CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    817       CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    818       CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
    819  
    820       ! ----------------------------------------------------------------------- 
    821       ! Copy useful data from the seaicedata data structure to 
    822       ! the seaicedatqc data structure  
    823       ! ----------------------------------------------------------------------- 
    824  
    825       ! Allocate the selection arrays 
    826  
    827       ALLOCATE( llvalid(seaicedata%nsurf) ) 
    828        
    829       ! We want all data which has qc flags <= 0 
    830  
    831       llvalid(:)  = ( seaicedata%nqc(:)  <= 10 ) 
    832  
    833       ! The actual copying 
    834  
    835       CALL obs_surf_compress( seaicedata,     seaicedatqc,       .TRUE.,  numout, & 
    836          &                    lvalid=llvalid ) 
    837  
    838       ! Dellocate the selection arrays 
    839       DEALLOCATE( llvalid ) 
    840  
    841       ! ----------------------------------------------------------------------- 
    842       ! Print information about what observations are left after qc 
    843       ! ----------------------------------------------------------------------- 
    844  
    845       ! Update the total observation counter array 
    846        
    847       IF(lwp) THEN 
    848          WRITE(numout,*) 
    849          WRITE(numout,*) 'obs_pre_seaice :' 
    850          WRITE(numout,*) '~~~~~~~~~~~' 
    851          WRITE(numout,*) 
    852          WRITE(numout,*) ' Sea ice data outside time domain                  = ', & 
    853             &            iotdobsmpp 
    854          WRITE(numout,*) ' Remaining sea ice data that failed grid search    = ', & 
    855             &            igrdobsmpp 
    856          WRITE(numout,*) ' Remaining sea ice data outside space domain       = ', & 
    857             &            iosdsobsmpp 
    858          WRITE(numout,*) ' Remaining sea ice data at land points             = ', & 
    859             &            ilansobsmpp 
    860          IF (ld_nea) THEN 
    861             WRITE(numout,*) ' Remaining sea ice data near land points (removed) = ', & 
    862                &            inlasobsmpp 
    863          ELSE 
    864             WRITE(numout,*) ' Remaining sea ice data near land points (kept)    = ', & 
    865                &            inlasobsmpp 
    866          ENDIF 
    867          WRITE(numout,*) ' Sea ice data accepted                             = ', & 
    868             &            seaicedatqc%nsurfmpp 
    869  
    870          WRITE(numout,*) 
    871          WRITE(numout,*) ' Number of observations per time step :' 
    872          WRITE(numout,*) 
    873          WRITE(numout,1997) 
    874          WRITE(numout,1998) 
    875       ENDIF 
    876        
    877       DO jobs = 1, seaicedatqc%nsurf 
    878          inrc = seaicedatqc%mstp(jobs) + 2 - nit000 
    879          seaicedatqc%nsstp(inrc)  = seaicedatqc%nsstp(inrc) + 1 
    880       END DO 
    881        
    882       CALL obs_mpp_sum_integers( seaicedatqc%nsstp, seaicedatqc%nsstpmpp, & 
    883          &                       nitend - nit000 + 2 ) 
    884  
    885       IF ( lwp ) THEN 
    886          DO jstp = nit000 - 1, nitend 
    887             inrc = jstp - nit000 + 2 
    888             WRITE(numout,1999) jstp, seaicedatqc%nsstpmpp(inrc) 
    889          END DO 
    890       ENDIF 
    891  
    892 1997  FORMAT(10X,'Time step',5X,'Sea ice data           ') 
    893 1998  FORMAT(10X,'---------',5X,'-----------------') 
    894 1999  FORMAT(10X,I9,5X,I17) 
    895        
    896    END SUBROUTINE obs_pre_seaice 
    897  
    898    SUBROUTINE obs_pre_vel( profdata, prodatqc, ld_vel3d, ld_nea, ld_dailyav ) 
    899       !!---------------------------------------------------------------------- 
    900       !!                    ***  ROUTINE obs_pre_taovel  *** 
    901       !! 
    902       !! ** Purpose : First level check and screening of U and V profiles 
    903       !! 
    904       !! ** Method  : First level check and screening of U and V profiles 
    905       !! 
    906       !! History : 
    907       !!        !  2007-06  (K. Mogensen) original : T and S profile data 
    908       !!        !  2008-09  (M. Valdivieso) : TAO velocity data 
    909       !!        !  2009-01  (K. Mogensen) : New feedback strictuer 
    910       !! 
    911       !!---------------------------------------------------------------------- 
    912       !! * Modules used 
    913       USE domstp              ! Domain: set the time-step 
    914       USE par_oce             ! Ocean parameters 
    915       USE dom_oce, ONLY : &   ! Geographical information 
    916          & glamt, glamu, glamv,    & 
    917          & gphit, gphiu, gphiv,    & 
    918          & gdept_1d,             & 
    919          & tmask, umask, vmask,  & 
    920          & nproc 
    921       !! * Arguments 
    922       TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    923       TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening 
    924       LOGICAL, INTENT(IN) :: ld_vel3d      ! Switch for zonal and meridional velocity components 
    925       LOGICAL, INTENT(IN) :: ld_nea        ! Switch for rejecting observation near land 
    926       LOGICAL, INTENT(IN) :: ld_dailyav    ! Switch for daily average data 
    927       !! * Local declarations 
    928       INTEGER :: iyea0        ! Initial date 
    929       INTEGER :: imon0        !  - (year, month, day, hour, minute) 
    930       INTEGER :: iday0     
    931       INTEGER :: ihou0     
    932       INTEGER :: imin0 
    933       INTEGER :: icycle       ! Current assimilation cycle 
    934                               ! Counters for observations that 
    935       INTEGER :: iotdobs      !  - outside time domain 
    936       INTEGER :: iosduobs     !  - outside space domain (zonal velocity component) 
    937       INTEGER :: iosdvobs     !  - outside space domain (meridional velocity component) 
    938       INTEGER :: ilanuobs     !  - within a model land cell (zonal velocity component) 
    939       INTEGER :: ilanvobs     !  - within a model land cell (meridional velocity component) 
    940       INTEGER :: inlauobs     !  - close to land (zonal velocity component) 
    941       INTEGER :: inlavobs     !  - close to land (meridional velocity component) 
    942       INTEGER :: igrdobs      !  - fail the grid search 
    943       INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    944       INTEGER :: iuvchkv      ! 
    945                               ! Global counters for observations that 
    946       INTEGER :: iotdobsmpp   !  - outside time domain 
    947       INTEGER :: iosduobsmpp  !  - outside space domain (zonal velocity component) 
    948       INTEGER :: iosdvobsmpp  !  - outside space domain (meridional velocity component) 
    949       INTEGER :: ilanuobsmpp  !  - within a model land cell (zonal velocity component) 
    950       INTEGER :: ilanvobsmpp  !  - within a model land cell (meridional velocity component) 
    951       INTEGER :: inlauobsmpp  !  - close to land (zonal velocity component) 
    952       INTEGER :: inlavobsmpp  !  - close to land (meridional velocity component) 
    953       INTEGER :: igrdobsmpp   !  - fail the grid search 
    954       INTEGER :: iuvchkumpp   !  - reject u if v rejected and vice versa 
    955       INTEGER :: iuvchkvmpp   ! 
    956       TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
    957       TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    958          & llvvalid           ! U,V selection  
    959       INTEGER :: jvar         ! Variable loop variable 
    960       INTEGER :: jobs         ! Obs. loop variable 
    961       INTEGER :: jstp         ! Time loop variable 
    962       INTEGER :: inrc         ! Time index variable 
    963  
    964       IF(lwp) WRITE(numout,*)'obs_pre_vel: Preparing the velocity profile data' 
    965  
    966       ! Initial date initialization (year, month, day, hour, minute) 
    967       iyea0 =   ndate0 / 10000 
    968       imon0 = ( ndate0 - iyea0 * 10000 ) / 100 
    969       iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100 
    970       ihou0 = 0 
    971       imin0 = 0 
    972  
    973       icycle = no     ! Assimilation cycle 
    974  
    975       ! Diagnotics counters for various failures. 
    976  
    977       iotdobs  = 0 
    978       igrdobs  = 0 
    979       iosduobs = 0 
    980       iosdvobs = 0 
    981       ilanuobs = 0 
    982       ilanvobs = 0 
    983       inlauobs = 0 
    984       inlavobs = 0 
    985       iuvchku  = 0 
    986       iuvchkv = 0 
    987  
    988       ! ----------------------------------------------------------------------- 
    989       ! Find time coordinate for profiles 
    990       ! ----------------------------------------------------------------------- 
    991  
    992       CALL obs_coo_tim_prof( icycle, & 
    993          &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
    994          &              profdata%nprof,   profdata%nyea, profdata%nmon, & 
    995          &              profdata%nday,    profdata%nhou, profdata%nmin, & 
    996          &              profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
    997          &              iotdobs, ld_dailyav = ld_dailyav        ) 
    998      
    999       CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    1000        
    1001       ! ----------------------------------------------------------------------- 
    1002       ! Check for profiles failing the grid search 
    1003       ! ----------------------------------------------------------------------- 
    1004  
    1005       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,1), profdata%mj(:,1), & 
    1006          &              profdata%nqc,     igrdobs                         ) 
    1007       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,2), profdata%mj(:,2), & 
    1008          &              profdata%nqc,     igrdobs                         ) 
    1009  
    1010       CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    1011  
    1012       ! ----------------------------------------------------------------------- 
    1013       ! Reject all observations for profiles with nqc > 10 
    1014       ! ----------------------------------------------------------------------- 
    1015  
    1016       CALL obs_pro_rej( profdata ) 
     399      ! Reject all observations for profiles with nqc > iqc_cutoff 
     400      ! ----------------------------------------------------------------------- 
     401 
     402      CALL obs_pro_rej( profdata, kqc_cutoff = iqc_cutoff ) 
    1017403 
    1018404      ! ----------------------------------------------------------------------- 
    … …  
    1021407      ! ----------------------------------------------------------------------- 
    1022408 
    1023       ! Zonal Velocity Component 
    1024  
    1025       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    1026          &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    1027          &                 jpi,                   jpj,                  & 
    1028          &                 jpk,                                         & 
    1029          &                 profdata%mi,           profdata%mj,          &  
    1030          &                 profdata%var(1)%mvk,                         & 
    1031          &                 profdata%rlam,         profdata%rphi,        & 
    1032          &                 profdata%var(1)%vdep,                        & 
    1033          &                 glamu,                 gphiu,                & 
    1034          &                 gdept_1d,              umask,                & 
    1035          &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    1036          &                 iosduobs,              ilanuobs,             & 
    1037          &                 inlauobs,              ld_nea                ) 
    1038  
    1039       CALL obs_mpp_sum_integer( iosduobs, iosduobsmpp ) 
    1040       CALL obs_mpp_sum_integer( ilanuobs, ilanuobsmpp ) 
    1041       CALL obs_mpp_sum_integer( inlauobs, inlauobsmpp ) 
    1042  
    1043       ! Meridional Velocity Component 
    1044  
    1045       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    1046          &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    1047          &                 jpi,                   jpj,                  & 
    1048          &                 jpk,                                         & 
    1049          &                 profdata%mi,           profdata%mj,          &  
    1050          &                 profdata%var(2)%mvk,                         & 
    1051          &                 profdata%rlam,         profdata%rphi,        & 
    1052          &                 profdata%var(2)%vdep,                        & 
    1053          &                 glamv,                 gphiv,                & 
    1054          &                 gdept_1d,              vmask,                & 
    1055          &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    1056          &                 iosdvobs,              ilanvobs,             & 
    1057          &                 inlavobs,              ld_nea                ) 
    1058  
    1059       CALL obs_mpp_sum_integer( iosdvobs, iosdvobsmpp ) 
    1060       CALL obs_mpp_sum_integer( ilanvobs, ilanvobsmpp ) 
    1061       CALL obs_mpp_sum_integer( inlavobs, inlavobsmpp ) 
     409      DO jvar = 1, profdata%nvar 
     410         CALL obs_coo_spc_3d( profdata%nprof,          profdata%nvprot(jvar),   & 
     411            &                 profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 
     412            &                 jpi,                     jpj,                     & 
     413            &                 jpk,                                              & 
     414            &                 profdata%mi,             profdata%mj,             & 
     415            &                 profdata%var(jvar)%mvk,                           & 
     416            &                 profdata%rlam,           profdata%rphi,           & 
     417            &                 profdata%var(jvar)%vdep,                          & 
     418            &                 pglam(:,:,jvar),         pgphi(:,:,jvar),         & 
     419            &                 gdept_1d,                zmask(:,:,:,jvar),       & 
     420            &                 profdata%nqc,            profdata%var(jvar)%nvqc, & 
     421            &                 iosdvobs(jvar),          ilanvobs(jvar),          & 
     422            &                 inlavobs(jvar),          ld_nea,                  & 
     423            &                 ibdyvobs(jvar),          ld_bound_reject,         & 
     424            &                 iqc_cutoff       ) 
     425 
     426         CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 
     427         CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 
     428         CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 
     429         CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 
     430      END DO 
    1062431 
    1063432      ! ----------------------------------------------------------------------- 
    … …  
    1065434      ! ----------------------------------------------------------------------- 
    1066435 
    1067       CALL obs_uv_rej( profdata, iuvchku, iuvchkv ) 
    1068       CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 
    1069       CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 
     436      IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
     437         CALL obs_uv_rej( profdata, iuvchku, iuvchkv, iqc_cutoff ) 
     438         CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 
     439         CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 
     440      ENDIF 
    1070441 
    1071442      ! ----------------------------------------------------------------------- 
    … …  
    1081452      END DO 
    1082453 
    1083       ! We want all data which has qc flags = 0 
    1084  
    1085       llvalid%luse(:) = ( profdata%nqc(:)  <= 10 ) 
     454      ! We want all data which has qc flags <= iqc_cutoff 
     455 
     456      llvalid%luse(:) = ( profdata%nqc(:)  <= iqc_cutoff ) 
    1086457      DO jvar = 1,profdata%nvar 
    1087          llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= 10 ) 
     458         llvvalid(jvar)%luse(:) = ( profdata%var(jvar)%nvqc(:) <= iqc_cutoff ) 
    1088459      END DO 
    1089460 
    … …  
    1106477       
    1107478      IF(lwp) THEN 
     479       
    1108480         WRITE(numout,*) 
    1109          WRITE(numout,*) 'obs_pre_vel :' 
    1110          WRITE(numout,*) '~~~~~~~~~~~' 
    1111          WRITE(numout,*) 
    1112          WRITE(numout,*) ' Profiles outside time domain                = ', & 
     481         WRITE(numout,*) ' Profiles outside time domain                       = ', & 
    1113482            &            iotdobsmpp 
    1114          WRITE(numout,*) ' Remaining profiles that failed grid search  = ', & 
     483         WRITE(numout,*) ' Remaining profiles that failed grid search         = ', & 
    1115484            &            igrdobsmpp 
    1116          WRITE(numout,*) ' Remaining U data outside space domain       = ', & 
    1117             &            iosduobsmpp 
    1118          WRITE(numout,*) ' Remaining U data at land points             = ', & 
    1119             &            ilanuobsmpp 
    1120          IF (ld_nea) THEN 
    1121             WRITE(numout,*) ' Remaining U data near land points (removed) = ',& 
    1122                &            inlauobsmpp 
    1123          ELSE 
    1124             WRITE(numout,*) ' Remaining U data near land points (kept)    = ',& 
    1125                &            inlauobsmpp 
    1126          ENDIF 
    1127          WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
    1128             &            iuvchku      
    1129          WRITE(numout,*) ' U data accepted                             = ', & 
    1130             &            prodatqc%nvprotmpp(1) 
    1131          WRITE(numout,*) ' Remaining V data outside space domain       = ', & 
    1132             &            iosdvobsmpp 
    1133          WRITE(numout,*) ' Remaining V data at land points             = ', & 
    1134             &            ilanvobsmpp 
    1135          IF (ld_nea) THEN 
    1136             WRITE(numout,*) ' Remaining V data near land points (removed) = ',& 
    1137                &            inlavobsmpp 
    1138          ELSE 
    1139             WRITE(numout,*) ' Remaining V data near land points (kept)    = ',& 
    1140                &            inlavobsmpp 
    1141          ENDIF 
    1142          WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
    1143             &            iuvchkv      
    1144          WRITE(numout,*) ' V data accepted                             = ', & 
    1145             &            prodatqc%nvprotmpp(2) 
     485         DO jvar = 1, profdata%nvar 
     486            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain       = ', & 
     487               &            iosdvobsmpp(jvar) 
     488            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points             = ', & 
     489               &            ilanvobsmpp(jvar) 
     490            IF (ld_nea) THEN 
     491               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 
     492                  &            inlavobsmpp(jvar) 
     493            ELSE 
     494               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept)    = ',& 
     495                  &            inlavobsmpp(jvar) 
     496            ENDIF 
     497            IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 
     498               WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
     499                  &            iuvchku 
     500            ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 
     501               WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
     502                  &            iuvchkv 
     503            ENDIF 
     504            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 
     505                  &            ibdyvobsmpp(jvar) 
     506            WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted                             = ', & 
     507               &            prodatqc%nvprotmpp(jvar) 
     508         END DO 
    1146509 
    1147510         WRITE(numout,*) 
    1148511         WRITE(numout,*) ' Number of observations per time step :' 
    1149512         WRITE(numout,*) 
    1150          WRITE(numout,997) 
    1151          WRITE(numout,998) 
     513         WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 
     514         WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 
     515         DO jvar = 1, prodatqc%nvar 
     516            WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 
     517            WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 
     518         END DO 
     519         WRITE(numout,*) cout1 
     520         WRITE(numout,*) cout2 
    1152521      ENDIF 
    1153522       
    … …  
    1176545         DO jstp = nit000 - 1, nitend 
    1177546            inrc = jstp - nit000 + 2 
    1178             WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    1179                &                    prodatqc%nvstpmpp(inrc,1), & 
    1180                &                    prodatqc%nvstpmpp(inrc,2) 
     547            WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 
     548            DO jvar = 1, prodatqc%nvar 
     549               WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 
     550            END DO 
     551            WRITE(numout,*) cout1 
    1181552         END DO 
    1182553      ENDIF 
    1183554 
    1184 997   FORMAT(10X,'Time step',5X,'Profiles',5X,'Zonal Comp.',5X,'Meridional Comp.') 
    1185 998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 
    1186 999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    1187  
    1188    END SUBROUTINE obs_pre_vel 
     555   END SUBROUTINE obs_pre_prof 
    1189556 
    1190557   SUBROUTINE obs_coo_tim( kcycle, & 
    … …  
    1293660            &        .AND. ( kobsmin(jobs) <= kmin0 ) ) ) THEN 
    1294661            kobsstp(jobs) = -1 
    1295             kobsqc(jobs)  = kobsqc(jobs) + 11 
     662            kobsqc(jobs)  = IBSET(kobsqc(jobs),13) 
    1296663            kotdobs       = kotdobs + 1 
    1297664            CYCLE 
    … …  
    1344711         IF ( ( kobsstp(jobs) < ( nit000 - 1 ) ) & 
    1345712            & .OR.( kobsstp(jobs) > nitend ) ) THEN 
    1346             kobsqc(jobs) = kobsqc(jobs) + 12 
     713            kobsqc(jobs) = IBSET(kobsqc(jobs),13) 
    1347714            kotdobs = kotdobs + 1 
    1348715            CYCLE 
    … …  
    1389756      &                    kobsyea, kobsmon, kobsday, kobshou, kobsmin,   & 
    1390757      &                    ktyp,    kobsqc,  kobsstp, kotdobs, kdailyavtypes, & 
    1391       &                    ld_dailyav ) 
     758      &                    kqc_cutoff ) 
    1392759      !!---------------------------------------------------------------------- 
    1393760      !!                    ***  ROUTINE obs_coo_tim *** 
    … …  
    1433800      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    1434801         & kdailyavtypes    ! Types for daily averages 
    1435       LOGICAL, OPTIONAL :: ld_dailyav    ! All types are daily averages 
     802      INTEGER, OPTIONAL, INTENT(IN) :: kqc_cutoff           ! QC cutoff value 
     803 
    1436804      !! * Local declarations 
    1437805      INTEGER :: jobs 
     806      INTEGER :: iqc_cutoff=255 
    1438807 
    1439808      !----------------------------------------------------------------------- 
    … …  
    1454823         DO jobs = 1, kobsno 
    1455824             
    1456             IF ( kobsqc(jobs) <= 10 ) THEN 
     825            IF ( kobsqc(jobs) <= iqc_cutoff ) THEN 
    1457826                
    1458827               IF ( ( kobsstp(jobs) == (nit000 - 1) ).AND.& 
    1459828                  & ( ANY (kdailyavtypes(:) == ktyp(jobs)) ) ) THEN 
    1460                   kobsqc(jobs) = kobsqc(jobs) + 14 
     829                  kobsqc(jobs) = IBSET(kobsqc(jobs),13) 
    1461830                  kotdobs      = kotdobs + 1 
    1462831                  CYCLE 
    … …  
    1467836      ENDIF 
    1468837 
    1469       !------------------------------------------------------------------------ 
    1470       ! If ld_dailyav is set then all data assumed to be daily averaged 
    1471       !------------------------------------------------------------------------ 
    1472        
    1473       IF ( PRESENT( ld_dailyav) ) THEN 
    1474          IF (ld_dailyav) THEN 
    1475             DO jobs = 1, kobsno 
    1476                 
    1477                IF ( kobsqc(jobs) <= 10 ) THEN 
    1478                    
    1479                   IF ( kobsstp(jobs) == (nit000 - 1) ) THEN 
    1480                      kobsqc(jobs) = kobsqc(jobs) + 14 
    1481                      kotdobs      = kotdobs + 1 
    1482                      CYCLE 
    1483                   ENDIF 
    1484                    
    1485                ENDIF 
    1486             END DO 
    1487          ENDIF 
    1488       ENDIF 
    1489838 
    1490839   END SUBROUTINE obs_coo_tim_prof 
    … …  
    1521870      DO jobs = 1, kobsno 
    1522871         IF ( ( kobsi(jobs) <= 0 ) .AND. ( kobsj(jobs) <= 0 ) ) THEN 
    1523             kobsqc(jobs) = kobsqc(jobs) + 18 
     872            kobsqc(jobs) = IBSET(kobsqc(jobs),12) 
    1524873            kgrdobs = kgrdobs + 1 
    1525874         ENDIF 
    … …  
    1532881      &                       plam,   pphi,    pmask,            & 
    1533882      &                       kobsqc, kosdobs, klanobs,          & 
    1534       &                       knlaobs,ld_nea                     ) 
     883      &                       knlaobs,ld_nea,                    & 
     884      &                       kbdyobs,ld_bound_reject,           & 
     885      &                       kqc_cutoff                         ) 
    1535886      !!---------------------------------------------------------------------- 
    1536887      !!                    ***  ROUTINE obs_coo_spc_2d  *** 
    … …  
    1565916      INTEGER, DIMENSION(kobsno), INTENT(INOUT) :: & 
    1566917         & kobsqc             ! Observation quality control 
    1567       INTEGER, INTENT(INOUT) :: kosdobs   ! Observations outside space domain 
    1568       INTEGER, INTENT(INOUT) :: klanobs   ! Observations within a model land cell 
    1569       INTEGER, INTENT(INOUT) :: knlaobs   ! Observations near land 
    1570       LOGICAL, INTENT(IN) :: ld_nea       ! Flag observations near land 
     918      INTEGER, INTENT(INOUT) :: kosdobs          ! Observations outside space domain 
     919      INTEGER, INTENT(INOUT) :: klanobs          ! Observations within a model land cell 
     920      INTEGER, INTENT(INOUT) :: knlaobs          ! Observations near land 
     921      INTEGER, INTENT(INOUT) :: kbdyobs          ! Observations near boundary 
     922      LOGICAL, INTENT(IN)    :: ld_nea           ! Flag observations near land 
     923      LOGICAL, INTENT(IN)    :: ld_bound_reject  ! Flag observations near open boundary  
     924      INTEGER, INTENT(IN)    :: kqc_cutoff       ! Cutoff QC value 
     925 
    1571926      !! * Local declarations 
    1572927      REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 
    1573928         & zgmsk              ! Grid mask 
     929#if defined key_bdy  
     930      REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 
     931         & zbmsk              ! Boundary mask 
     932      REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 
     933#endif  
    1574934      REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 
    1575935         & zglam, &           ! Model longitude at grid points 
    … …  
    1588948         ! For invalid points use 2,2 
    1589949 
    1590          IF ( kobsqc(jobs) >= 10 ) THEN 
     950         IF ( kobsqc(jobs) >= kqc_cutoff ) THEN 
    1591951 
    1592952            igrdi(1,1,jobs) = 1 
    … …  
    1613973 
    1614974      END DO 
    1615        
    1616       CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pmask, zgmsk ) 
    1617       CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, plam, zglam ) 
    1618       CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pphi, zgphi ) 
     975 
     976#if defined key_bdy              
     977      ! Create a mask grid points in boundary rim 
     978      IF (ld_bound_reject) THEN 
     979         zbdymask(:,:) = 1.0_wp 
     980         DO ji = 1, nb_bdy 
     981            DO jj = 1, idx_bdy(ji)%nblen(1) 
     982               zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 
     983            ENDDO 
     984         ENDDO 
     985  
     986         CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 
     987      ENDIF 
     988#endif        
     989       
     990      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) 
     991      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) 
     992      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 
    1619993 
    1620994      DO jobs = 1, kobsno 
    1621995 
    1622996         ! Skip bad observations 
    1623          IF ( kobsqc(jobs) >= 10 ) CYCLE 
     997         IF ( kobsqc(jobs) >= kqc_cutoff ) CYCLE 
    1624998 
    1625999         ! Flag if the observation falls outside the model spatial domain 
    … …  
    16281002            &  .OR. ( pobsphi(jobs) <  -90. ) & 
    16291003            &  .OR. ( pobsphi(jobs) >   90. ) ) THEN 
    1630             kobsqc(jobs) = kobsqc(jobs) + 11 
     1004            kobsqc(jobs) = IBSET(kobsqc(jobs),11) 
    16311005            kosdobs = kosdobs + 1 
    16321006            CYCLE 
    … …  
    16351009         ! Flag if the observation falls with a model land cell 
    16361010         IF ( SUM( zgmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 
    1637             kobsqc(jobs) = kobsqc(jobs)  + 12 
     1011            kobsqc(jobs) = IBSET(kobsqc(jobs),10) 
    16381012            klanobs = klanobs + 1 
    16391013            CYCLE 
    … …  
    16491023               IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 
    16501024                  & .AND. & 
    1651                   & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp ) & 
    1652                   & ) THEN 
     1025                  & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) & 
     1026                  & < 1.0e-6_wp ) ) THEN 
    16531027                  lgridobs = .TRUE. 
    16541028                  iig = ji 
    … …  
    16571031            END DO 
    16581032         END DO 
    1659    
    1660          ! For observations on the grid reject them if their are at 
    1661          ! a masked point 
    1662           
     1033  
    16631034         IF (lgridobs) THEN 
    16641035            IF (zgmsk(iig,ijg,jobs) == 0.0_wp ) THEN 
    1665                kobsqc(jobs) = kobsqc(jobs) + 12 
     1036               kobsqc(jobs) = IBSET(kobsqc(jobs),10) 
    16661037               klanobs = klanobs + 1 
    16671038               CYCLE 
    16681039            ENDIF 
    16691040         ENDIF 
    1670                        
     1041 
     1042  
    16711043         ! Flag if the observation falls is close to land 
    16721044         IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN 
    1673             IF (ld_nea) kobsqc(jobs) = kobsqc(jobs) + 14 
    16741045            knlaobs = knlaobs + 1 
    1675             CYCLE 
     1046            IF (ld_nea) THEN 
     1047               kobsqc(jobs) = IBSET(kobsqc(jobs),9) 
     1048               CYCLE 
     1049            ENDIF 
    16761050         ENDIF 
     1051 
     1052#if defined key_bdy 
     1053         ! Flag if the observation falls close to the boundary rim 
     1054         IF (ld_bound_reject) THEN 
     1055            IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 
     1056               kobsqc(jobs) = IBSET(kobsqc(jobs),8) 
     1057               kbdyobs = kbdyobs + 1 
     1058               CYCLE 
     1059            ENDIF 
     1060            ! for observations on the grid... 
     1061            IF (lgridobs) THEN 
     1062               IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 
     1063                  kobsqc(jobs) = IBSET(kobsqc(jobs),8) 
     1064                  kbdyobs = kbdyobs + 1 
     1065                  CYCLE 
     1066               ENDIF 
     1067            ENDIF 
     1068         ENDIF 
     1069#endif  
    16771070             
    16781071      END DO 
    … …  
    16861079      &                       plam,    pphi,    pdep,    pmask, & 
    16871080      &                       kpobsqc, kobsqc,  kosdobs,        & 
    1688       &                       klanobs, knlaobs, ld_nea          ) 
     1081      &                       klanobs, knlaobs, ld_nea,         & 
     1082      &                       kbdyobs, ld_bound_reject,         & 
     1083      &                       kqc_cutoff                        ) 
    16891084      !!---------------------------------------------------------------------- 
    16901085      !!                    ***  ROUTINE obs_coo_spc_3d  *** 
    … …  
    17091104      !! * Modules used 
    17101105      USE dom_oce, ONLY : &       ! Geographical information 
    1711          & gdepw_1d                         
     1106         & gdepw_1d,      & 
     1107         & gdepw_0,       &                        
     1108#if defined key_vvl 
     1109         & gdepw_n,       &  
     1110         & gdept_n,       & 
     1111#endif 
     1112         & ln_zco,        & 
     1113         & ln_zps,        & 
     1114         & lk_vvl                         
    17121115 
    17131116      !! * Arguments 
    … …  
    17431146      INTEGER, INTENT(INOUT) :: klanobs     ! Observations within a model land cell 
    17441147      INTEGER, INTENT(INOUT) :: knlaobs     ! Observations near land 
     1148      INTEGER, INTENT(INOUT) :: kbdyobs     ! Observations near boundary 
    17451149      LOGICAL, INTENT(IN) :: ld_nea         ! Flag observations near land 
     1150      LOGICAL, INTENT(IN) :: ld_bound_reject  ! Flag observations near open boundary 
     1151      INTEGER, INTENT(IN) :: kqc_cutoff     ! Cutoff QC value 
     1152 
    17461153      !! * Local declarations 
    17471154      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 
    17481155         & zgmsk              ! Grid mask 
     1156#if defined key_bdy  
     1157      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 
     1158         & zbmsk              ! Boundary mask 
     1159      REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask 
     1160#endif  
     1161      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 
     1162         & zgdept, & 
     1163         & zgdepw          
    17491164      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 
    17501165         & zglam, &           ! Model longitude at grid points 
    1751          & zgphi              ! Model latitude at grid points 
     1166         & zgphi, &           ! Model latitude at grid points 
     1167         & zbathy             ! Index of deepest wet level at grid points 
    17521168      INTEGER, DIMENSION(2,2,kprofno) :: & 
    17531169         & igrdi, &           ! Grid i,j 
    17541170         & igrdj 
    17551171      LOGICAL :: lgridobs           ! Is observation on a model grid point. 
     1172      LOGICAL :: ll_next_to_land    ! Is a profile next to land  
    17561173      INTEGER :: iig, ijg           ! i,j of observation on model grid point. 
    17571174      INTEGER :: jobs, jobsp, jk, ji, jj 
     1175      REAL(KIND=wp) :: maxdepw 
    17581176 
    17591177      ! Get grid point indices 
    … …  
    17631181         ! For invalid points use 2,2 
    17641182 
    1765          IF ( kpobsqc(jobs) >= 10 ) THEN 
     1183         IF ( kpobsqc(jobs) >= kqc_cutoff ) THEN 
    17661184             
    17671185            igrdi(1,1,jobs) = 1 
    … …  
    17881206          
    17891207      END DO 
    1790        
    1791       CALL obs_int_comm_3d( 2, 2, kprofno, kpk, igrdi, igrdj, pmask, zgmsk ) 
    1792       CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, plam, zglam ) 
    1793       CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, pphi, zgphi ) 
     1208 
     1209#if defined key_bdy  
     1210      ! Create a mask grid points in boundary rim 
     1211      IF (ld_bound_reject) THEN            
     1212         zbdymask(:,:) = 1.0_wp 
     1213         DO ji = 1, nb_bdy 
     1214            DO jj = 1, idx_bdy(ji)%nblen(1) 
     1215               zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp 
     1216            ENDDO 
     1217         ENDDO 
     1218      ENDIF 
     1219  
     1220      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, zbdymask, zbmsk ) 
     1221#endif  
     1222       
     1223      CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) 
     1224      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 
     1225      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 
     1226      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, REAL(mbathy), zbathy ) 
     1227      ! Need to know the bathy depth for each observation for sco 
     1228      CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, fsdepw(:,:,:), & 
     1229         &                  zgdepw ) 
     1230      CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, fsdept(:,:,:), & 
     1231         &                  zgdept ) 
    17941232 
    17951233      DO jobs = 1, kprofno 
    17961234 
    17971235         ! Skip bad profiles 
    1798          IF ( kpobsqc(jobs) >= 10 ) CYCLE 
     1236         IF ( kpobsqc(jobs) >= kqc_cutoff ) CYCLE 
    17991237 
    18001238         ! Check if this observation is on a grid point 
    … …  
    18071245               IF ( ( ABS( zgphi(ji,jj,jobs) - pobsphi(jobs) ) < 1.0e-6_wp ) & 
    18081246                  & .AND. & 
    1809                   & ( ABS( zglam(ji,jj,jobs) - pobslam(jobs) ) < 1.0e-6_wp ) & 
     1247                  & ( ABS( MOD( zglam(ji,jj,jobs) - pobslam(jobs),360.0) ) < 1.0e-6_wp ) & 
    18101248                  & ) THEN 
    18111249                  lgridobs = .TRUE. 
    … …  
    18161254         END DO 
    18171255 
     1256         ! Check if next to land  
     1257         IF (  ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN  
     1258            ll_next_to_land=.TRUE.  
     1259         ELSE  
     1260            ll_next_to_land=.FALSE.  
     1261         ENDIF  
     1262          
    18181263         ! Reject observations 
    18191264 
    18201265         DO jobsp = kpstart(jobs), kpend(jobs) 
     1266 
     1267            ! Calculate max T and W depths of 2x2 grid 
     1268            maxdepw=zgdepw(1,1,NINT(zbathy(1,1,jobs))+1,jobs) 
     1269            DO jj = 1, 2 
     1270               DO ji = 1, 2 
     1271                  IF ( zgdepw(ji,jj,NINT(zbathy(ji,jj,jobs))+1,jobs) > maxdepw ) THEN 
     1272                     maxdepw = zgdepw(ji,jj,NINT(zbathy(ji,jj,jobs))+1,jobs) 
     1273                  END IF 
     1274               END DO 
     1275            END DO 
    18211276 
    18221277            ! Flag if the observation falls outside the model spatial domain 
    … …  
    18261281               &  .OR. ( pobsphi(jobs) >   90.         )       & 
    18271282               &  .OR. ( pobsdep(jobsp) < 0.0          )       & 
    1828                &  .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 
    1829                kobsqc(jobsp) = kobsqc(jobsp) + 11 
     1283               &  .OR. ( pobsdep(jobsp) >= maxdepw ) ) THEN 
     1284               kobsqc(jobsp) = IBSET(kobsqc(jobsp),11) 
    18301285               kosdobs = kosdobs + 1 
    18311286               CYCLE 
    18321287            ENDIF 
    18331288 
    1834             ! Flag if the observation falls with a model land cell 
    1835             IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 
    1836                &  == 0.0_wp ) THEN 
    1837                kobsqc(jobsp) = kobsqc(jobsp) + 12 
    1838                klanobs = klanobs + 1 
    1839                CYCLE 
     1289            ! To check if an observations falls within land there are two cases:  
     1290            ! 1: z-coordibnates, where the check uses the mask  
     1291            ! 2: terrain following (eg s-coordinates),   
     1292            !    where we use the depth of the bottom cell to mask observations  
     1293              
     1294            IF( (.NOT. lk_vvl) .AND. ( ln_zps .OR. ln_zco )  ) THEN !(CASE 1)  
     1295                 
     1296               ! Flag if the observation falls with a model land cell  
     1297               IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) &  
     1298                  &  == 0.0_wp ) THEN  
     1299                  kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 
     1300                  klanobs = klanobs + 1  
     1301                  CYCLE  
     1302               ENDIF  
     1303              
     1304               ! Flag if the observation is close to land  
     1305               IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == &  
     1306                  &  0.0_wp) THEN  
     1307                  knlaobs = knlaobs + 1  
     1308                  IF (ld_nea) THEN    
     1309                     kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 
     1310                  ENDIF   
     1311               ENDIF  
     1312              
     1313            ELSE ! Case 2  
     1314               ! Flag if the observation is deeper than the bathymetry  
     1315               ! Or if it is within the mask  
     1316               IF ( ANY( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 
     1317                  &     .OR. &  
     1318                  &  ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 
     1319                  &  == 0.0_wp) ) THEN 
     1320                  kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 
     1321                  klanobs = klanobs + 1  
     1322                  CYCLE  
     1323               ENDIF  
     1324                 
     1325               ! Flag if the observation is close to land  
     1326               IF ( ll_next_to_land ) THEN  
     1327                  knlaobs = knlaobs + 1  
     1328                  IF (ld_nea) THEN    
     1329                     kobsqc(jobsp) = IBSET(kobsqc(jobsp),10) 
     1330                  ENDIF   
     1331               ENDIF  
     1332              
    18401333            ENDIF 
    18411334 
    … …  
    18451338            IF (lgridobs) THEN 
    18461339               IF (zgmsk(iig,ijg,kobsk(jobsp)-1,jobs) == 0.0_wp ) THEN 
    1847                   kobsqc(jobsp) = kobsqc(jobsp) + 12 
     1340                  kobsqc(jobsp) = IBSET(kobsqc(jobs),10) 
    18481341                  klanobs = klanobs + 1 
    18491342                  CYCLE 
    18501343               ENDIF 
    18511344            ENDIF 
    1852              
    1853             ! Flag if the observation falls is close to land 
    1854             IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 
    1855                &  0.0_wp) THEN 
    1856                IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 14 
    1857                knlaobs = knlaobs + 1 
     1345            
     1346#if defined key_bdy 
     1347            ! Flag if the observation falls close to the boundary rim 
     1348            IF (ld_bound_reject) THEN 
     1349               IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN 
     1350                  kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 
     1351                  kbdyobs = kbdyobs + 1 
     1352                  CYCLE 
     1353               ENDIF 
     1354               ! for observations on the grid... 
     1355               IF (lgridobs) THEN 
     1356                  IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN 
     1357                     kobsqc(jobsp) = IBSET(kobsqc(jobs),8) 
     1358                     kbdyobs = kbdyobs + 1 
     1359                     CYCLE 
     1360                  ENDIF 
     1361               ENDIF 
    18581362            ENDIF 
    1859  
    1860             ! Set observation depth equal to that of the first model depth 
    1861             IF ( pobsdep(jobsp) <= pdep(1) ) THEN 
    1862                pobsdep(jobsp) = pdep(1)   
    1863             ENDIF 
     1363#endif  
    18641364             
    18651365         END DO 
    … …  
    18681368   END SUBROUTINE obs_coo_spc_3d 
    18691369 
    1870    SUBROUTINE obs_pro_rej( profdata ) 
     1370   SUBROUTINE obs_pro_rej( profdata, kqc_cutoff ) 
    18711371      !!---------------------------------------------------------------------- 
    18721372      !!                    ***  ROUTINE obs_pro_rej *** 
    … …  
    18861386      !! * Arguments 
    18871387      TYPE(obs_prof), INTENT(INOUT) :: profdata     ! Profile data 
     1388      INTEGER, INTENT(IN) :: kqc_cutoff             ! QC cutoff value 
     1389 
    18881390      !! * Local declarations 
    18891391      INTEGER :: jprof 
    … …  
    18951397      DO jprof = 1, profdata%nprof 
    18961398 
    1897          IF ( profdata%nqc(jprof) > 10 ) THEN 
     1399         IF ( profdata%nqc(jprof) > kqc_cutoff ) THEN 
    18981400             
    18991401            DO jvar = 1, profdata%nvar 
    … …  
    19031405                   
    19041406                  profdata%var(jvar)%nvqc(jobs) = & 
    1905                      & profdata%var(jvar)%nvqc(jobs) + 26 
     1407                     & IBSET(profdata%var(jvar)%nvqc(jobs),14) 
    19061408 
    19071409               END DO 
    … …  
    19151417   END SUBROUTINE obs_pro_rej 
    19161418 
    1917    SUBROUTINE obs_uv_rej( profdata, knumu, knumv ) 
     1419   SUBROUTINE obs_uv_rej( profdata, knumu, knumv, kqc_cutoff ) 
    19181420      !!---------------------------------------------------------------------- 
    19191421      !!                    ***  ROUTINE obs_uv_rej *** 
    … …  
    19351437      INTEGER, INTENT(INOUT) :: knumu             ! Number of u rejected 
    19361438      INTEGER, INTENT(INOUT) :: knumv             ! Number of v rejected 
     1439      INTEGER, INTENT(IN) :: kqc_cutoff           ! QC cutoff value 
     1440 
    19371441      !! * Local declarations 
    19381442      INTEGER :: jprof 
    … …  
    19541458         DO jobs = profdata%npvsta(jprof,1), profdata%npvend(jprof,1) 
    19551459             
    1956             IF ( ( profdata%var(1)%nvqc(jobs) > 10 ) .AND. & 
    1957                & ( profdata%var(2)%nvqc(jobs) <= 10) ) THEN 
    1958                profdata%var(2)%nvqc(jobs) = profdata%var(2)%nvqc(jobs) + 42 
     1460            IF ( ( profdata%var(1)%nvqc(jobs) >  kqc_cutoff ) .AND. & 
     1461               & ( profdata%var(2)%nvqc(jobs) <=  kqc_cutoff) ) THEN 
     1462               profdata%var(2)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 
    19591463               knumv = knumv + 1 
    19601464            ENDIF 
    1961             IF ( ( profdata%var(2)%nvqc(jobs) > 10 ) .AND. & 
    1962                & ( profdata%var(1)%nvqc(jobs) <= 10) ) THEN 
    1963                profdata%var(1)%nvqc(jobs) = profdata%var(1)%nvqc(jobs) + 42 
     1465            IF ( ( profdata%var(2)%nvqc(jobs) >  kqc_cutoff ) .AND. & 
     1466               & ( profdata%var(1)%nvqc(jobs) <=  kqc_cutoff) ) THEN 
     1467               profdata%var(1)%nvqc(jobs) = IBSET(profdata%var(1)%nvqc(jobs),15) 
    19641468               knumu = knumu + 1 
    19651469            ENDIF 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90

    r8058 r15670  
    7272         & vdep,  &       !: Depth coordinate of profile data 
    7373         & vobs,  &       !: Profile data 
    74          & vmod           !: Model counterpart of the profile data vector 
    75  
     74         & vmod,  &       !: Model counterpart of the profile data vector 
     75         & vclm           !: Climatological counterpart of the profile data vector 
     76          
    7677      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
    7778         & vext           !: Extra variables 
    … …  
    102103      INTEGER :: nprofup  !: Observation counter used in obs_oper 
    103104 
     105      LOGICAL :: lclim    !: Climatology will be calculated for this structure 
     106       
    104107      ! Bookkeeping arrays with sizes equal to number of variables 
     108 
     109      CHARACTER(len=8), POINTER, DIMENSION(:) :: & 
     110         & cvars          !: Variable names 
    105111 
    106112      INTEGER, POINTER, DIMENSION(:) :: & 
    … …  
    195201    
    196202   SUBROUTINE obs_prof_alloc( prof,  kvar, kext, kprof,  & 
    197       &                       ko3dt, kstp, kpi, kpj, kpk ) 
     203      &                       ko3dt, kstp, kpi, kpj, kpk, ldclim ) 
    198204      !!---------------------------------------------------------------------- 
    199205      !!                     ***  ROUTINE obs_prof_alloc  *** 
    … …  
    218224      INTEGER, INTENT(IN) :: kpj 
    219225      INTEGER, INTENT(IN) :: kpk 
     226      LOGICAL, INTENT(IN) :: ldclim 
    220227 
    221228      !!* Local variables 
    … …  
    233240      prof%npj       = kpj 
    234241      prof%npk       = kpk 
     242       
     243      prof%lclim     = ldclim 
    235244 
    236245      ! Allocate arrays of size number of variables 
    237246 
    238247      ALLOCATE( & 
     248         & prof%cvars(kvar),    & 
    239249         & prof%nvprot(kvar),   & 
    240250         & prof%nvprotmpp(kvar) & 
    … …  
    242252          
    243253      DO jvar = 1, kvar 
     254         prof%cvars    (jvar) = "NotSet" 
    244255         prof%nvprot   (jvar) = ko3dt(jvar) 
    245256         prof%nvprotmpp(jvar) = 0 
    … …  
    452463 
    453464      DEALLOCATE( & 
    454          & prof%nvprot,  & 
     465         & prof%cvars,    & 
     466         & prof%nvprot,   & 
    455467         & prof%nvprotmpp & 
    456468         ) 
    … …  
    497509            & ) 
    498510      ENDIF 
     511      IF (prof%lclim) THEN 
     512         ALLOCATE( &  
     513            & prof%var(kvar)%vclm(kobs) & 
     514            & ) 
     515      ENDIF 
    499516 
    500517   END SUBROUTINE obs_prof_alloc_var 
    … …  
    531548         DEALLOCATE( &  
    532549            & prof%var(kvar)%vext  & 
     550            & ) 
     551      ENDIF 
     552      IF (prof%lclim) THEN 
     553         DEALLOCATE( &  
     554            & prof%var(kvar)%vclm  & 
    533555            & ) 
    534556      ENDIF 
    … …  
    624646            &                 inprof,    invpro,    & 
    625647            &                 prof%nstp, prof%npi,  & 
    626             &                 prof%npj,  prof%npk ) 
     648            &                 prof%npj,  prof%npk,  & 
     649            &                 prof%lclim ) 
    627650      ENDIF 
    628651 
    … …  
    739762                           &                      prof%var(jvar)%vext(jj,jext) 
    740763                     END DO 
    741                    
     764                     IF (newprof%lclim) THEN 
     765                        newprof%var(jvar)%vclm(invpro(jvar))   = & 
     766                           &                           prof%var(jvar)%vclm(jj) 
     767                     ENDIF 
     768                                     
    742769                     ! nvind is the index of the original variable data 
    743770                      
    … …  
    770797      newprof%npj      = prof%npj 
    771798      newprof%npk      = prof%npk 
     799      newprof%cvars(:) = prof%cvars(:) 
    772800  
    773801      ! Deallocate temporary data 
    … …  
    863891                     &                        prof%var(jvar)%vext(jj,jext) 
    864892               END DO 
    865                 
     893               IF (prof%lclim) THEN 
     894                  oldprof%var(jvar)%vclm(jl)   = prof%var(jvar)%vclm(jj) 
     895               ENDIF               
    866896            END DO 
    867897 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_altbias.F90

    r8058 r15670  
    5050CONTAINS 
    5151 
    52    SUBROUTINE obs_rea_altbias( kslano, sladata, k2dint, bias_file ) 
     52   SUBROUTINE obs_rea_altbias( sladata, k2dint, bias_file ) 
    5353      !!--------------------------------------------------------------------- 
    5454      !! 
    … …  
    7070      ! 
    7171      !! * Arguments 
    72       INTEGER, INTENT(IN) :: kslano      ! Number of SLA Products 
    73       TYPE(obs_surf), DIMENSION(kslano), INTENT(INOUT) :: & 
     72      TYPE(obs_surf), INTENT(INOUT) :: & 
    7473         & sladata       ! SLA data 
    7574      INTEGER, INTENT(IN) :: k2dint 
    … …  
    8079      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_rea_altbias' 
    8180 
    82       INTEGER :: jslano       ! Data set loop variable 
    8381      INTEGER :: jobs         ! Obs loop variable 
    8482      INTEGER :: jpialtbias   ! Number of grid point in latitude for the bias 
    … …  
    130128         ! Get the Alt bias data 
    131129          
    132          CALL iom_get( numaltbias, jpdom_data, 'altbias', z_altbias(:,:), 1 ) 
     130         CALL iom_get( numaltbias, jpdom_autoglo, 'altbias', z_altbias(:,:), 1 ) 
    133131          
    134132         ! Close the file 
    … …  
    144142      ! Intepolate the bias already on the model grid at the observation point 
    145143   
    146       DO jslano = 1, kslano 
    147  
    148          ALLOCATE( & 
    149             & igrdi(2,2,sladata(jslano)%nsurf), & 
    150             & igrdj(2,2,sladata(jslano)%nsurf), & 
    151             & zglam(2,2,sladata(jslano)%nsurf), & 
    152             & zgphi(2,2,sladata(jslano)%nsurf), & 
    153             & zmask(2,2,sladata(jslano)%nsurf), & 
    154             & zbias(2,2,sladata(jslano)%nsurf)  & 
    155             & ) 
    156           
    157          DO jobs = 1, sladata(jslano)%nsurf 
    158  
    159             igrdi(1,1,jobs) = sladata(jslano)%mi(jobs)-1 
    160             igrdj(1,1,jobs) = sladata(jslano)%mj(jobs)-1 
    161             igrdi(1,2,jobs) = sladata(jslano)%mi(jobs)-1 
    162             igrdj(1,2,jobs) = sladata(jslano)%mj(jobs) 
    163             igrdi(2,1,jobs) = sladata(jslano)%mi(jobs) 
    164             igrdj(2,1,jobs) = sladata(jslano)%mj(jobs)-1 
    165             igrdi(2,2,jobs) = sladata(jslano)%mi(jobs) 
    166             igrdj(2,2,jobs) = sladata(jslano)%mj(jobs) 
    167  
    168          END DO 
    169  
    170          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    171             &                  igrdi, igrdj, glamt, zglam ) 
    172          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    173             &                  igrdi, igrdj, gphit, zgphi ) 
    174          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    175             &                  igrdi, igrdj, tmask(:,:,1), zmask ) 
    176          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    177             &                  igrdi, igrdj, z_altbias, zbias ) 
    178  
    179          DO jobs = 1, sladata(jslano)%nsurf 
    180  
    181             zlam = sladata(jslano)%rlam(jobs) 
    182             zphi = sladata(jslano)%rphi(jobs) 
    183             iico = sladata(jslano)%mi(jobs) 
    184             ijco = sladata(jslano)%mj(jobs) 
     144      ALLOCATE( & 
     145         & igrdi(2,2,sladata%nsurf), & 
     146         & igrdj(2,2,sladata%nsurf), & 
     147         & zglam(2,2,sladata%nsurf), & 
     148         & zgphi(2,2,sladata%nsurf), & 
     149         & zmask(2,2,sladata%nsurf), & 
     150         & zbias(2,2,sladata%nsurf)  & 
     151         & ) 
     152          
     153      DO jobs = 1, sladata%nsurf 
     154 
     155         igrdi(1,1,jobs) = sladata%mi(jobs)-1 
     156         igrdj(1,1,jobs) = sladata%mj(jobs)-1 
     157         igrdi(1,2,jobs) = sladata%mi(jobs)-1 
     158         igrdj(1,2,jobs) = sladata%mj(jobs) 
     159         igrdi(2,1,jobs) = sladata%mi(jobs) 
     160         igrdj(2,1,jobs) = sladata%mj(jobs)-1 
     161         igrdi(2,2,jobs) = sladata%mi(jobs) 
     162         igrdj(2,2,jobs) = sladata%mj(jobs) 
     163 
     164      END DO 
     165 
     166      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 
     167         &                  igrdi, igrdj, glamt, zglam ) 
     168      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 
     169         &                  igrdi, igrdj, gphit, zgphi ) 
     170      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 
     171         &                  igrdi, igrdj, tmask(:,:,1), zmask ) 
     172      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, & 
     173         &                  igrdi, igrdj, z_altbias, zbias ) 
     174 
     175      DO jobs = 1, sladata%nsurf 
     176 
     177         zlam = sladata%rlam(jobs) 
     178         zphi = sladata%rphi(jobs) 
     179         iico = sladata%mi(jobs) 
     180         ijco = sladata%mj(jobs) 
    185181             
    186             CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
    187                &                   zglam(:,:,jobs), zgphi(:,:,jobs), & 
    188                &                   zmask(:,:,jobs), zweig, zobsmask ) 
     182         CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
     183            &                   zglam(:,:,jobs), zgphi(:,:,jobs), & 
     184            &                   zmask(:,:,jobs), zweig, zobsmask ) 
    189185             
    190             CALL obs_int_h2d( 1, 1,      & 
    191                &              zweig, zbias(:,:,jobs),  zext ) 
    192  
    193             ! adjust mdt with bias field 
    194             sladata(jslano)%rext(jobs,2) = & 
    195                sladata(jslano)%rext(jobs,2) - zext(1) 
     186         CALL obs_int_h2d( 1, 1,      & 
     187            &              zweig, zbias(:,:,jobs),  zext ) 
     188 
     189         ! adjust mdt with bias field 
     190         sladata%rext(jobs,2) = sladata%rext(jobs,2) - zext(1) 
    196191             
    197          END DO 
    198  
    199          DEALLOCATE( & 
    200             & igrdi, & 
    201             & igrdj, & 
    202             & zglam, & 
    203             & zgphi, & 
    204             & zmask, & 
    205             & zbias  & 
    206             & ) 
    207           
    208192      END DO 
    209193 
     194      DEALLOCATE( & 
     195         & igrdi, & 
     196         & igrdj, & 
     197         & zglam, & 
     198         & zgphi, & 
     199         & zmask, & 
     200         & zbias  & 
     201         & ) 
     202          
    210203      CALL wrk_dealloc(jpi,jpj,z_altbias)  
    211204 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90

    r8058 r15670  
    2525   USE netcdf                   ! NetCDF library 
    2626   USE obs_oper                 ! Observation operators 
    27    USE obs_prof_io              ! Profile files I/O (non-FB files) 
    2827   USE lib_mpp                  ! For ctl_warn/stop 
     28   USE obs_fbm                  ! Feedback routines 
    2929 
    3030   IMPLICIT NONE 
    … …  
    3333   PRIVATE 
    3434 
    35    PUBLIC obs_rea_pro_dri  ! Read the profile observations  
     35   PUBLIC obs_rea_prof  ! Read the profile observations  
    3636 
    3737   !!---------------------------------------------------------------------- 
    … …  
    4242 
    4343CONTAINS 
    44   
    45    SUBROUTINE obs_rea_pro_dri( kformat, & 
    46       &                        profdata, knumfiles, cfilenames, & 
    47       &                        kvars, kextr, kstp, ddobsini, ddobsend, & 
    48       &                        ldt3d, lds3d, ldignmis, ldsatt, ldavtimset, & 
    49       &                        ldmod, kdailyavtypes ) 
     44 
     45   SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & 
     46      &                     kvars, kextr, kstp, ddobsini, ddobsend, & 
     47      &                     ldvar, ldignmis, ldsatt, & 
     48      &                     ldmod, ldclim, cdvars, kdailyavtypes ) 
    5049      !!--------------------------------------------------------------------- 
    5150      !! 
    52       !!                   *** ROUTINE obs_rea_pro_dri *** 
     51      !!                   *** ROUTINE obs_rea_prof *** 
    5352      !! 
    5453      !! ** Purpose : Read from file the profile observations 
    5554      !! 
    56       !! ** Method  : Depending on kformat either ENACT, CORIOLIS or 
    57       !!              feedback data files are read 
     55      !! ** Method  : Read feedback data in and transform to NEMO internal  
     56      !!              profile data structure 
    5857      !! 
    5958      !! ** Action  :  
    … …  
    6362      !! History :   
    6463      !!      ! :  2009-09 (K. Mogensen) : New merged version of old routines 
     64      !!      ! :  2015-08 (M. Martin) : Merged profile and velocity routines 
    6565      !!---------------------------------------------------------------------- 
    66       !! * Modules used 
    67     
     66 
    6867      !! * Arguments 
    69       INTEGER ::  kformat    ! Format of input data 
    70       !                      ! 1: ENACT 
    71       !                      ! 2: Coriolis 
    72       TYPE(obs_prof), INTENT(OUT) ::  profdata     ! Profile data to be read 
    73       INTEGER, INTENT(IN) :: knumfiles      ! Number of files to read in 
     68      TYPE(obs_prof), INTENT(OUT) :: & 
     69         & profdata                     ! Profile data to be read 
     70      INTEGER, INTENT(IN) :: knumfiles  ! Number of files to read 
    7471      CHARACTER(LEN=128), INTENT(IN) ::  & 
    75          & cfilenames(knumfiles)  ! File names to read in 
     72         & cdfilenames(knumfiles)        ! File names to read in 
    7673      INTEGER, INTENT(IN) :: kvars      ! Number of variables in profdata 
    77       INTEGER, INTENT(IN) :: kextr      ! Number of extra fields for each var in profdata 
    78       INTEGER, INTENT(IN) :: kstp        ! Ocean time-step index 
    79       LOGICAL, INTENT(IN) :: ldt3d       ! Observed variables switches 
    80       LOGICAL, INTENT(IN) :: lds3d 
    81       LOGICAL, INTENT(IN) :: ldignmis    ! Ignore missing files 
    82       LOGICAL, INTENT(IN) :: ldsatt      ! Compute salinity at all temperature points 
    83       LOGICAL, INTENT(IN) :: ldavtimset  ! Correct time for daily averaged data 
    84       LOGICAL, INTENT(IN) :: ldmod       ! Initialize model from input data 
    85       REAL(KIND=dp), INTENT(IN) :: ddobsini    ! Obs. ini time in YYYYMMDD.HHMMSS 
    86       REAL(KIND=dp), INTENT(IN) :: ddobsend    ! Obs. end time in YYYYMMDD.HHMMSS 
     74      INTEGER, INTENT(IN) :: kextr      ! Number of extra fields for each var 
     75      INTEGER, INTENT(IN) :: kstp       ! Ocean time-step index 
     76      LOGICAL, DIMENSION(kvars), INTENT(IN) :: ldvar     ! Observed variables switches 
     77      LOGICAL, INTENT(IN) :: ldignmis   ! Ignore missing files 
     78      LOGICAL, INTENT(IN) :: ldsatt     ! Compute salinity at all temperature points 
     79      LOGICAL, INTENT(IN) :: ldmod      ! Initialize model from input data 
     80      LOGICAL, INTENT(IN) :: ldclim     ! Set flag to show climatology will be output 
     81      REAL(dp), INTENT(IN) :: ddobsini  ! Obs. ini time in YYYYMMDD.HHMMSS 
     82      REAL(dp), INTENT(IN) :: ddobsend  ! Obs. end time in YYYYMMDD.HHMMSS 
     83      CHARACTER(len=8), DIMENSION(kvars), INTENT(IN) :: cdvars 
    8784      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    88          & kdailyavtypes 
     85         & kdailyavtypes                ! Types of daily average observations 
    8986 
    9087      !! * Local declarations 
    91       CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_pro_dri' 
     88      CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 
     89      CHARACTER(len=8) :: clrefdate 
     90      CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvarsin 
    9291      INTEGER :: jvar 
    9392      INTEGER :: ji 
    … …  
    105104      INTEGER :: imin 
    106105      INTEGER :: isec 
     106      INTEGER :: iprof 
     107      INTEGER :: iproftot 
     108      INTEGER, DIMENSION(kvars) :: ivart0 
     109      INTEGER, DIMENSION(kvars) :: ivart 
     110      INTEGER :: ip3dt 
     111      INTEGER :: ios 
     112      INTEGER :: ioserrcount 
     113      INTEGER, DIMENSION(kvars) :: ivartmpp 
     114      INTEGER :: ip3dtmpp 
     115      INTEGER :: itype 
    107116      INTEGER, DIMENSION(knumfiles) :: & 
    108117         & irefdate 
    109       INTEGER, DIMENSION(ntyp1770+1) :: & 
    110          & itypt,    & 
    111          & ityptmpp, & 
    112          & ityps,    & 
    113          & itypsmpp  
    114       INTEGER :: it3dtmpp 
    115       INTEGER :: is3dtmpp 
    116       INTEGER :: ip3dtmpp 
    117       INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     118      INTEGER, DIMENSION(ntyp1770+1,kvars) :: & 
     119         & itypvar,    & 
     120         & itypvarmpp 
     121      INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 
    118122         & iobsi,    & 
    119123         & iobsj,    & 
    120          & iproc,    & 
     124         & iproc 
     125      INTEGER, DIMENSION(:), ALLOCATABLE :: & 
    121126         & iindx,    & 
    122127         & ifileidx, & 
    123128         & iprofidx 
    124       INTEGER :: itype 
    125129      INTEGER, DIMENSION(imaxavtypes) :: & 
    126130         & idailyavtypes 
     131      INTEGER, DIMENSION(kvars) :: & 
     132         & iv3dt 
    127133      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    128134         & zphi, & 
    129135         & zlam 
    130       real(wp), DIMENSION(:), ALLOCATABLE :: & 
     136      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    131137         & zdat 
     138      REAL(wp), DIMENSION(knumfiles) :: & 
     139         & djulini, & 
     140         & djulend 
    132141      LOGICAL :: llvalprof 
     142      LOGICAL :: lldavtimset 
     143      LOGICAL :: llcycle 
    133144      TYPE(obfbdata), POINTER, DIMENSION(:) :: & 
    134145         & inpfiles 
    135       real(wp), DIMENSION(knumfiles) :: & 
    136          & djulini, & 
    137          & djulend 
    138       INTEGER :: iprof 
    139       INTEGER :: iproftot 
    140       INTEGER :: it3dt0 
    141       INTEGER :: is3dt0 
    142       INTEGER :: it3dt 
    143       INTEGER :: is3dt 
    144       INTEGER :: ip3dt 
    145       INTEGER :: ios 
    146       INTEGER :: ioserrcount 
    147       INTEGER, DIMENSION(kvars) :: & 
    148          & iv3dt 
    149       CHARACTER(len=8) :: cl_refdate 
    150     
     146 
    151147      ! Local initialization 
    152148      iprof = 0 
    153       it3dt0 = 0 
    154       is3dt0 = 0 
     149      ivart0(:) = 0 
    155150      ip3dt = 0 
    156151 
    157152      ! Daily average types 
     153      lldavtimset = .FALSE. 
    158154      IF ( PRESENT(kdailyavtypes) ) THEN 
    159155         idailyavtypes(:) = kdailyavtypes(:) 
     156         IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE. 
    160157      ELSE 
    161158         idailyavtypes(:) = -1 
    … …  
    163160 
    164161      !----------------------------------------------------------------------- 
    165       ! Check data the model part is just with feedback data files 
    166       !----------------------------------------------------------------------- 
    167       IF ( ldmod .AND. ( kformat /= 0 ) ) THEN 
    168          CALL ctl_stop( 'Model can only be read from feedback data' ) 
    169          RETURN 
    170       ENDIF 
    171  
    172       !----------------------------------------------------------------------- 
    173162      ! Count the number of files needed and allocate the obfbdata type 
    174163      !----------------------------------------------------------------------- 
    175        
     164 
    176165      inobf = knumfiles 
    177        
     166 
    178167      ALLOCATE( inpfiles(inobf) ) 
    179168 
    180169      prof_files : DO jj = 1, inobf 
    181            
     170 
    182171         !--------------------------------------------------------------------- 
    183172         ! Prints 
    … …  
    186175            WRITE(numout,*) 
    187176            WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', & 
    188                & TRIM( TRIM( cfilenames(jj) ) ) 
     177               & TRIM( TRIM( cdfilenames(jj) ) ) 
    189178            WRITE(numout,*) ' ~~~~~~~~~~~~~~~' 
    190179            WRITE(numout,*) 
    … …  
    194183         !  Initialization: Open file and get dimensions only 
    195184         !--------------------------------------------------------------------- 
    196           
    197          iflag = nf90_open( TRIM( TRIM( cfilenames(jj) ) ), nf90_nowrite, & 
     185 
     186         iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, & 
    198187            &                      i_file_id ) 
    199           
     188 
    200189         IF ( iflag /= nf90_noerr ) THEN 
    201190 
    202191            IF ( ldignmis ) THEN 
    203192               inpfiles(jj)%nobs = 0 
    204                CALL ctl_warn( 'File ' // TRIM( TRIM( cfilenames(jj) ) ) // & 
     193               CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // & 
    205194                  &           ' not found' ) 
    206195            ELSE  
    207                CALL ctl_stop( 'File ' // TRIM( TRIM( cfilenames(jj) ) ) // & 
     196               CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // & 
    208197                  &           ' not found' ) 
    209198            ENDIF 
    210199 
    211200         ELSE  
    212              
     201 
    213202            !------------------------------------------------------------------ 
    214             !  Close the file since it is opened in read_proffile 
     203            !  Close the file since it is opened in read_obfbdata 
    215204            !------------------------------------------------------------------ 
    216              
     205 
    217206            iflag = nf90_close( i_file_id ) 
    218207 
    … …  
    220209            !  Read the profile file into inpfiles 
    221210            !------------------------------------------------------------------ 
    222             IF ( kformat == 0 ) THEN 
    223                CALL init_obfbdata( inpfiles(jj) ) 
    224                IF(lwp) THEN 
    225                   WRITE(numout,*) 
    226                   WRITE(numout,*)'Reading from feedback file :', & 
    227                      &           TRIM( cfilenames(jj) ) 
    228                ENDIF 
    229                CALL read_obfbdata( TRIM( cfilenames(jj) ), inpfiles(jj), & 
    230                   &                ldgrid = .TRUE. ) 
    231                IF ( inpfiles(jj)%nvar < 2 ) THEN 
    232                   CALL ctl_stop( 'Feedback format error' ) 
    233                   RETURN 
    234                ENDIF 
    235                IF ( TRIM(inpfiles(jj)%cname(1)) /= 'POTM' ) THEN 
    236                   CALL ctl_stop( 'Feedback format error' ) 
    237                   RETURN 
    238                ENDIF 
    239                IF ( TRIM(inpfiles(jj)%cname(2)) /= 'PSAL' ) THEN 
    240                   CALL ctl_stop( 'Feedback format error' ) 
    241                   RETURN 
    242                ENDIF 
    243                IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 
    244                   CALL ctl_stop( 'Model not in input data' ) 
    245                   RETURN 
    246                ENDIF 
    247             ELSEIF ( kformat == 1 ) THEN 
    248                CALL read_enactfile( TRIM( cfilenames(jj) ), inpfiles(jj), & 
    249                   &                 numout, lwp, .TRUE. ) 
    250             ELSEIF ( kformat == 2 ) THEN 
    251                CALL read_coriofile( TRIM( cfilenames(jj) ), inpfiles(jj), & 
    252                   &                 numout, lwp, .TRUE. ) 
     211            CALL init_obfbdata( inpfiles(jj) ) 
     212            CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & 
     213               &                ldgrid = .TRUE. ) 
     214 
     215            IF ( inpfiles(jj)%nvar /= kvars ) THEN 
     216               CALL ctl_stop( 'Feedback format error: ', & 
     217                  &           ' unexpected number of vars in profile file' ) 
     218            ENDIF 
     219 
     220            IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 
     221               CALL ctl_stop( 'Model not in input data' ) 
     222            ENDIF 
     223 
     224            IF ( jj == 1 ) THEN 
     225               ALLOCATE( clvarsin( inpfiles(jj)%nvar ) ) 
     226               DO ji = 1, inpfiles(jj)%nvar 
     227                 clvarsin(ji) = inpfiles(jj)%cname(ji) 
     228                 IF ( clvarsin(ji) /= cdvars(ji) ) THEN 
     229                    CALL ctl_stop( 'Feedback file variables do not match', & 
     230                        &           ' expected variable names for this type' ) 
     231                 ENDIF 
     232               END DO 
    253233            ELSE 
    254                CALL ctl_stop( 'File format unknown' ) 
    255             ENDIF 
    256              
     234               DO ji = 1, inpfiles(jj)%nvar 
     235                  IF ( inpfiles(jj)%cname(ji) /= clvarsin(ji) ) THEN 
     236                     CALL ctl_stop( 'Feedback file variables not consistent', & 
     237                        &           ' with previous files for this type' ) 
     238                  ENDIF 
     239               END DO 
     240            ENDIF 
     241 
    257242            !------------------------------------------------------------------ 
    258243            !  Change longitude (-180,180) 
    … …  
    272257            !  Calculate the date  (change eventually) 
    273258            !------------------------------------------------------------------ 
    274             cl_refdate=inpfiles(jj)%cdjuldref(1:8) 
    275             READ(cl_refdate,'(I8)') irefdate(jj) 
    276              
     259            clrefdate=inpfiles(jj)%cdjuldref(1:8) 
     260            READ(clrefdate,'(I8)') irefdate(jj) 
     261 
    277262            CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) 
    278263            CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & 
    … …  
    283268 
    284269            ioserrcount=0 
    285             IF ( ldavtimset ) THEN 
     270            IF ( lldavtimset ) THEN 
     271 
     272               IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN 
     273                  WRITE(numout,*)' Resetting time of daily averaged', & 
     274                     &           ' observations to the end of the day' 
     275               ENDIF 
     276 
    286277               DO ji = 1, inpfiles(jj)%nobs 
    287                   !  
    288                   !  for daily averaged data for example 
    289                   !  MRB data (itype==820) force the time 
    290                   !  to be the  end of the day 
    291                   ! 
    292278                  READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype 
    293279900               IF ( ios /= 0 ) THEN 
    294                      itype = 0         ! Set type to zero if there is a problem in the string conversion 
    295                   ENDIF 
    296                   IF ( ANY (idailyavtypes == itype ) ) THEN 
    297                      inpfiles(jj)%ptim(ji) = & 
    298                      & INT(inpfiles(jj)%ptim(ji)) + 1 
    299                   ENDIF 
     280                     ! Set type to zero if there is a problem in the string conversion 
     281                     itype = 0 
     282                  ENDIF 
     283 
     284                  IF ( ANY ( idailyavtypes(:) == itype ) ) THEN 
     285                  !  for daily averaged data force the time 
     286                  !  to be the last time-step of the day, but still within the day. 
     287                     IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN 
     288                        inpfiles(jj)%ptim(ji) = & 
     289                           & INT(inpfiles(jj)%ptim(ji)) + 0.9999 
     290                     ELSE 
     291                        inpfiles(jj)%ptim(ji) = & 
     292                           & INT(inpfiles(jj)%ptim(ji)) - 0.0001 
     293                     ENDIF 
     294                  ENDIF 
     295 
    300296               END DO 
    301             ENDIF 
    302              
     297 
     298            ENDIF 
     299 
    303300            IF ( inpfiles(jj)%nobs > 0 ) THEN 
    304                inpfiles(jj)%iproc = -1 
    305                inpfiles(jj)%iobsi = -1 
    306                inpfiles(jj)%iobsj = -1 
     301               inpfiles(jj)%iproc(:,:) = -1 
     302               inpfiles(jj)%iobsi(:,:) = -1 
     303               inpfiles(jj)%iobsj(:,:) = -1 
    307304            ENDIF 
    308305            inowin = 0 
    309306            DO ji = 1, inpfiles(jj)%nobs 
    310                IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    311                IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    312                   & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     307               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     308               llcycle = .TRUE. 
     309               DO jvar = 1, kvars 
     310                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     311                     llcycle = .FALSE. 
     312                     EXIT 
     313                  ENDIF 
     314               END DO 
     315               IF ( llcycle ) CYCLE 
    313316               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    314317                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    318321            ALLOCATE( zlam(inowin)  ) 
    319322            ALLOCATE( zphi(inowin)  ) 
    320             ALLOCATE( iobsi(inowin) ) 
    321             ALLOCATE( iobsj(inowin) ) 
    322             ALLOCATE( iproc(inowin) ) 
     323            ALLOCATE( iobsi(inowin,kvars) ) 
     324            ALLOCATE( iobsj(inowin,kvars) ) 
     325            ALLOCATE( iproc(inowin,kvars) ) 
    323326            inowin = 0 
    324327            DO ji = 1, inpfiles(jj)%nobs 
    325                IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    326                IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    327                   & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     328               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     329               llcycle = .TRUE. 
     330               DO jvar = 1, kvars 
     331                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     332                     llcycle = .FALSE. 
     333                     EXIT 
     334                  ENDIF 
     335               END DO 
     336               IF ( llcycle ) CYCLE 
    328337               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    329338                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    334343            END DO 
    335344 
    336             CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 
     345            ! Assume anything other than velocity is on T grid 
     346            IF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 
     347               CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 
     348                  &                  iproc(:,1), 'U' ) 
     349               CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,2), iobsj(:,2), & 
     350                  &                  iproc(:,2), 'V' ) 
     351            ELSE 
     352               CALL obs_grid_search( inowin, zlam, zphi, iobsi(:,1), iobsj(:,1), & 
     353                  &                  iproc(:,1), 'T' ) 
     354               IF ( kvars > 1 ) THEN 
     355                  DO jvar = 2, kvars 
     356                     iobsi(:,jvar) = iobsi(:,1) 
     357                     iobsj(:,jvar) = iobsj(:,1) 
     358                     iproc(:,jvar) = iproc(:,1) 
     359                  END DO 
     360               ENDIF 
     361            ENDIF 
    337362 
    338363            inowin = 0 
    339364            DO ji = 1, inpfiles(jj)%nobs 
    340                IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    341                IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    342                   & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     365               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     366               llcycle = .TRUE. 
     367               DO jvar = 1, kvars 
     368                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     369                     llcycle = .FALSE. 
     370                     EXIT 
     371                  ENDIF 
     372               END DO 
     373               IF ( llcycle ) CYCLE 
    343374               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    344375                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    345376                  inowin = inowin + 1 
    346                   inpfiles(jj)%iproc(ji,1) = iproc(inowin) 
    347                   inpfiles(jj)%iobsi(ji,1) = iobsi(inowin) 
    348                   inpfiles(jj)%iobsj(ji,1) = iobsj(inowin) 
     377                  DO jvar = 1, kvars 
     378                     inpfiles(jj)%iproc(ji,jvar) = iproc(inowin,jvar) 
     379                     inpfiles(jj)%iobsi(ji,jvar) = iobsi(inowin,jvar) 
     380                     inpfiles(jj)%iobsj(ji,jvar) = iobsj(inowin,jvar) 
     381                  END DO 
     382                  IF ( kvars > 1 ) THEN 
     383                     DO jvar = 2, kvars 
     384                        IF ( inpfiles(jj)%iproc(ji,jvar) /= & 
     385                           & inpfiles(jj)%iproc(ji,1) ) THEN 
     386                           CALL ctl_stop( 'Error in obs_read_prof:', & 
     387                              & 'observation on different processors for different vars') 
     388                        ENDIF 
     389                     END DO 
     390                  ENDIF 
    349391               ENDIF 
    350392            END DO 
    … …  
    352394 
    353395            DO ji = 1, inpfiles(jj)%nobs 
    354                IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    355                IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    356                   & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     396               IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     397               llcycle = .TRUE. 
     398               DO jvar = 1, kvars 
     399                  IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     400                     llcycle = .FALSE. 
     401                     EXIT 
     402                  ENDIF 
     403               END DO 
     404               IF ( llcycle ) CYCLE 
    357405               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    358406                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    363411                  ENDIF 
    364412                  llvalprof = .FALSE. 
    365                   IF ( ldt3d ) THEN 
    366                      loop_t_count : DO ij = 1,inpfiles(jj)%nlev 
    367                         IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    368                            & CYCLE 
    369                         IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    370                            & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    371                            it3dt0 = it3dt0 + 1 
    372                         ENDIF 
    373                      END DO loop_t_count 
    374                   ENDIF 
    375                   IF ( lds3d ) THEN 
    376                      loop_s_count : DO ij = 1,inpfiles(jj)%nlev 
    377                         IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    378                            & CYCLE 
    379                         IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    380                            & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    381                            is3dt0 = is3dt0 + 1 
    382                         ENDIF 
    383                      END DO loop_s_count 
    384                   ENDIF 
    385                   loop_p_count : DO ij = 1,inpfiles(jj)%nlev 
     413                  DO jvar = 1, kvars 
     414                     IF ( ldvar(jvar) ) THEN 
     415                        DO ij = 1,inpfiles(jj)%nlev 
     416                           IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
     417                              & CYCLE 
     418                           IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     419                              & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
     420                              ivart0(jvar) = ivart0(jvar) + 1 
     421                           ENDIF 
     422                        END DO 
     423                     ENDIF 
     424                  END DO 
     425                  DO ij = 1,inpfiles(jj)%nlev 
    386426                     IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    387427                        & CYCLE 
    388                      IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    389                         &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    390                         &     ldt3d ) .OR. & 
    391                         & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    392                         &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    393                         &     lds3d ) ) THEN 
    394                         ip3dt = ip3dt + 1 
    395                         llvalprof = .TRUE. 
    396                      ENDIF 
    397                   END DO loop_p_count 
     428                     DO jvar = 1, kvars 
     429                        IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     430                           &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
     431                           &    ldvar(jvar) ) ) THEN 
     432                           ip3dt = ip3dt + 1 
     433                           llvalprof = .TRUE. 
     434                           EXIT 
     435                        ENDIF 
     436                     END DO 
     437                  END DO 
    398438 
    399439                  IF ( llvalprof ) iprof = iprof + 1 
    … …  
    405445 
    406446      END DO prof_files 
    407        
     447 
    408448      !----------------------------------------------------------------------- 
    409449      ! Get the time ordered indices of the input data 
    … …  
    416456      DO jj = 1, inobf 
    417457         DO ji = 1, inpfiles(jj)%nobs 
    418             IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    419             IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    420                & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     458            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     459            llcycle = .TRUE. 
     460            DO jvar = 1, kvars 
     461               IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     462                  llcycle = .FALSE. 
     463                  EXIT 
     464               ENDIF 
     465            END DO 
     466            IF ( llcycle ) CYCLE 
    421467            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    422468               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    431477      DO jj = 1, inobf 
    432478         DO ji = 1, inpfiles(jj)%nobs 
    433             IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    434             IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    435                & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     479            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     480            llcycle = .TRUE. 
     481            DO jvar = 1, kvars 
     482               IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     483                  llcycle = .FALSE. 
     484                  EXIT 
     485               ENDIF 
     486            END DO 
     487            IF ( llcycle ) CYCLE 
    436488            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    437489               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    446498         &               zdat,     & 
    447499         &               iindx   ) 
    448        
     500 
    449501      iv3dt(:) = -1 
    450502      IF (ldsatt) THEN 
    451          iv3dt(1) = ip3dt 
    452          iv3dt(2) = ip3dt 
     503         iv3dt(:) = ip3dt 
    453504      ELSE 
    454          iv3dt(1) = it3dt0 
    455          iv3dt(2) = is3dt0 
     505         iv3dt(:) = ivart0(:) 
    456506      ENDIF 
    457507      CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & 
    458          &                 kstp, jpi, jpj, jpk ) 
    459        
     508         &                 kstp, jpi, jpj, jpk, ldclim ) 
     509 
    460510      ! * Read obs/positions, QC, all variable and assign to profdata 
    461511 
    462512      profdata%nprof     = 0 
    463513      profdata%nvprot(:) = 0 
    464  
     514      profdata%cvars(:)  = clvarsin(:) 
    465515      iprof = 0 
    466516 
    467517      ip3dt = 0 
    468       it3dt = 0 
    469       is3dt = 0 
    470       itypt   (:) = 0 
    471       ityptmpp(:) = 0 
    472        
    473       ityps   (:) = 0 
    474       itypsmpp(:) = 0 
    475        
    476       ioserrcount = 0       
     518      ivart(:) = 0 
     519      itypvar   (:,:) = 0 
     520      itypvarmpp(:,:) = 0 
     521 
     522      ioserrcount = 0 
    477523      DO jk = 1, iproftot 
    478           
     524 
    479525         jj = ifileidx(iindx(jk)) 
    480526         ji = iprofidx(iindx(jk)) 
    481527 
    482          IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    483          IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    484             & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     528         IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     529         llcycle = .TRUE. 
     530         DO jvar = 1, kvars 
     531            IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     532               llcycle = .FALSE. 
     533               EXIT 
     534            ENDIF 
     535         END DO 
     536         IF ( llcycle ) CYCLE 
    485537 
    486538         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  & 
    487539            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    488              
     540 
    489541            IF ( nproc == 0 ) THEN 
    490542               IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE 
    … …  
    492544               IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
    493545            ENDIF 
    494              
     546 
    495547            llvalprof = .FALSE. 
    496548 
    497549            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
    498550 
    499             IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .AND. & 
    500                & ( inpfiles(jj)%ivqc(ji,2) > 2 ) ) CYCLE 
     551            IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE 
     552            llcycle = .TRUE. 
     553            DO jvar = 1, kvars 
     554               IF ( .NOT. ( BTEST(inpfiles(jj)%ivqc(ji,jvar),2) ) ) THEN 
     555                  llcycle = .FALSE. 
     556                  EXIT 
     557               ENDIF 
     558            END DO 
     559            IF ( llcycle ) CYCLE 
    501560 
    502561            loop_prof : DO ij = 1, inpfiles(jj)%nlev 
    503                 
     562 
    504563               IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    505564                  & CYCLE 
    506                 
    507                IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    508                   & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    509                    
    510                   llvalprof = .TRUE.  
    511                   EXIT loop_prof 
    512                    
    513                ENDIF 
    514                 
    515                IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    516                   & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    517                    
    518                   llvalprof = .TRUE.  
    519                   EXIT loop_prof 
    520                    
    521                ENDIF 
    522                 
     565 
     566               DO jvar = 1, kvars 
     567                  IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     568                     & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
     569 
     570                     llvalprof = .TRUE.  
     571                     EXIT loop_prof 
     572 
     573                  ENDIF 
     574               END DO 
     575 
    523576            END DO loop_prof 
    524              
     577 
    525578            ! Set profile information 
    526              
     579 
    527580            IF ( llvalprof ) THEN 
    528                 
     581 
    529582               iprof = iprof + 1 
    530583 
    … …  
    545598               profdata%nhou(iprof) = ihou 
    546599               profdata%nmin(iprof) = imin 
    547                 
     600 
    548601               ! Profile space coordinates 
    549602               profdata%rlam(iprof) = inpfiles(jj)%plam(ji) 
    … …  
    551604 
    552605               ! Coordinate search parameters 
    553                profdata%mi  (iprof,:) = inpfiles(jj)%iobsi(ji,1) 
    554                profdata%mj  (iprof,:) = inpfiles(jj)%iobsj(ji,1) 
    555                 
     606               DO jvar = 1, kvars 
     607                  profdata%mi  (iprof,jvar) = inpfiles(jj)%iobsi(ji,jvar) 
     608                  profdata%mj  (iprof,jvar) = inpfiles(jj)%iobsj(ji,jvar) 
     609               END DO 
     610 
    556611               ! Profile WMO number 
    557612               profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji) 
    558                 
     613 
    559614               ! Instrument type 
    560615               READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype 
    … …  
    564619                  itype = 0 
    565620               ENDIF 
    566                 
     621 
    567622               profdata%ntyp(iprof) = itype 
    568                 
     623 
    569624               ! QC stuff 
    570625 
    … …  
    585640               profdata%nqc(iprof)  = 0 !TODO 
    586641 
    587                loop_p : DO ij = 1, inpfiles(jj)%nlev             
    588                    
     642               loop_p : DO ij = 1, inpfiles(jj)%nlev 
     643 
    589644                  IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    590645                     & CYCLE 
    … …  
    592647                  IF (ldsatt) THEN 
    593648 
    594                      IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    595                         &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    596                         &     ldt3d ) .OR. & 
    597                         & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    598                         &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    599                         &     lds3d ) ) THEN 
    600                         ip3dt = ip3dt + 1 
    601                      ELSE 
    602                         CYCLE 
     649                     DO jvar = 1, kvars 
     650                        IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     651                           &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
     652                           &    ldvar(jvar) ) ) THEN 
     653                           ip3dt = ip3dt + 1 
     654                           EXIT 
     655                        ELSE IF ( jvar == kvars ) THEN 
     656                           CYCLE loop_p 
     657                        ENDIF 
     658                     END DO 
     659 
     660                  ENDIF 
     661 
     662                  DO jvar = 1, kvars 
     663                   
     664                     IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     665                       &   .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & 
     666                       &    ldvar(jvar) ) .OR. ldsatt ) THEN 
     667 
     668                        IF (ldsatt) THEN 
     669 
     670                           ivart(jvar) = ip3dt 
     671 
     672                        ELSE 
     673 
     674                           ivart(jvar) = ivart(jvar) + 1 
     675 
     676                        ENDIF 
     677 
     678                        ! Depth of jvar observation 
     679                        profdata%var(jvar)%vdep(ivart(jvar)) = & 
     680                           &                inpfiles(jj)%pdep(ij,ji) 
     681 
     682                        ! Depth of jvar observation QC 
     683                        profdata%var(jvar)%idqc(ivart(jvar)) = & 
     684                           &                inpfiles(jj)%idqc(ij,ji) 
     685 
     686                        ! Depth of jvar observation QC flags 
     687                        profdata%var(jvar)%idqcf(:,ivart(jvar)) = & 
     688                           &                inpfiles(jj)%idqcf(:,ij,ji) 
     689 
     690                        ! Profile index 
     691                        profdata%var(jvar)%nvpidx(ivart(jvar)) = iprof 
     692 
     693                        ! Vertical index in original profile 
     694                        profdata%var(jvar)%nvlidx(ivart(jvar)) = ij 
     695 
     696                        ! Profile jvar value 
     697                        IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,jvar),2) .AND. & 
     698                           & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN 
     699                           profdata%var(jvar)%vobs(ivart(jvar)) = & 
     700                              &                inpfiles(jj)%pob(ij,ji,jvar) 
     701                           IF ( ldmod ) THEN 
     702                              profdata%var(jvar)%vmod(ivart(jvar)) = & 
     703                                 &                inpfiles(jj)%padd(ij,ji,1,jvar) 
     704                           ENDIF 
     705                           IF ( profdata%lclim ) THEN 
     706                               profdata%var(jvar)%vclm(ivart(jvar)) = fbrmdi 
     707                           ENDIF                           
     708                           ! Count number of profile var1 data as function of type 
     709                           itypvar( profdata%ntyp(iprof) + 1, jvar ) = & 
     710                              & itypvar( profdata%ntyp(iprof) + 1, jvar ) + 1 
     711                        ELSE 
     712                           profdata%var(jvar)%vobs(ivart(jvar)) = fbrmdi 
     713                        ENDIF 
     714 
     715                        ! Profile jvar qc 
     716                        profdata%var(jvar)%nvqc(ivart(jvar)) = & 
     717                           & inpfiles(jj)%ivlqc(ij,ji,jvar) 
     718 
     719                        ! Profile jvar qc flags 
     720                        profdata%var(jvar)%nvqcf(:,ivart(jvar)) = & 
     721                           & inpfiles(jj)%ivlqcf(:,ij,ji,jvar) 
     722 
     723                        ! Profile insitu T value 
     724                        IF ( TRIM( inpfiles(jj)%cname(jvar) ) == 'POTM' ) THEN 
     725                           profdata%var(jvar)%vext(ivart(jvar),1) = & 
     726                              &                inpfiles(jj)%pext(ij,ji,1) 
     727                        ENDIF 
     728 
    603729                     ENDIF 
    604                       
    605                   ENDIF 
    606  
    607                   IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    608                      &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    609                      &       ldt3d ) .OR. ldsatt ) THEN 
    610                       
    611                      IF (ldsatt) THEN 
    612  
    613                         it3dt = ip3dt 
    614  
    615                      ELSE 
    616  
    617                         it3dt = it3dt + 1 
    618                          
    619                      ENDIF 
    620  
    621                      ! Depth of T observation 
    622                      profdata%var(1)%vdep(it3dt) = & 
    623                         &                inpfiles(jj)%pdep(ij,ji) 
    624                       
    625                      ! Depth of T observation QC 
    626                      profdata%var(1)%idqc(it3dt) = & 
    627                         &                inpfiles(jj)%idqc(ij,ji) 
    628                       
    629                      ! Depth of T observation QC flags 
    630                      profdata%var(1)%idqcf(:,it3dt) = & 
    631                         &                inpfiles(jj)%idqcf(:,ij,ji) 
    632                       
    633                      ! Profile index 
    634                      profdata%var(1)%nvpidx(it3dt) = iprof 
    635                       
    636                      ! Vertical index in original profile 
    637                      profdata%var(1)%nvlidx(it3dt) = ij 
    638  
    639                      ! Profile potential T value 
    640                      IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    641                         & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    642                         profdata%var(1)%vobs(it3dt) = & 
    643                            &                inpfiles(jj)%pob(ij,ji,1) 
    644                         IF ( ldmod ) THEN 
    645                            profdata%var(1)%vmod(it3dt) = & 
    646                               &                inpfiles(jj)%padd(ij,ji,1,1) 
    647                         ENDIF 
    648                         ! Count number of profile T data as function of type 
    649                         itypt( profdata%ntyp(iprof) + 1 ) = & 
    650                            & itypt( profdata%ntyp(iprof) + 1 ) + 1 
    651                      ELSE 
    652                         profdata%var(1)%vobs(it3dt) = fbrmdi 
    653                      ENDIF 
    654  
    655                      ! Profile T qc 
    656                      profdata%var(1)%nvqc(it3dt) = & 
    657                         & inpfiles(jj)%ivlqc(ij,ji,1) 
    658  
    659                      ! Profile T qc flags 
    660                      profdata%var(1)%nvqcf(:,it3dt) = & 
    661                         & inpfiles(jj)%ivlqcf(:,ij,ji,1) 
    662  
    663                      ! Profile insitu T value 
    664                      profdata%var(1)%vext(it3dt,1) = & 
    665                         &                inpfiles(jj)%pext(ij,ji,1) 
    666                       
    667                   ENDIF 
    668730                   
    669                   IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    670                      &   ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    671                      &   lds3d ) .OR. ldsatt ) THEN 
    672                       
    673                      IF (ldsatt) THEN 
    674  
    675                         is3dt = ip3dt 
    676  
    677                      ELSE 
    678  
    679                         is3dt = is3dt + 1 
    680                          
    681                      ENDIF 
    682  
    683                      ! Depth of S observation 
    684                      profdata%var(2)%vdep(is3dt) = & 
    685                         &                inpfiles(jj)%pdep(ij,ji) 
    686                       
    687                      ! Depth of S observation QC 
    688                      profdata%var(2)%idqc(is3dt) = & 
    689                         &                inpfiles(jj)%idqc(ij,ji) 
    690                       
    691                      ! Depth of S observation QC flags 
    692                      profdata%var(2)%idqcf(:,is3dt) = & 
    693                         &                inpfiles(jj)%idqcf(:,ij,ji) 
    694                       
    695                      ! Profile index 
    696                      profdata%var(2)%nvpidx(is3dt) = iprof 
    697                       
    698                      ! Vertical index in original profile 
    699                      profdata%var(2)%nvlidx(is3dt) = ij 
    700  
    701                      ! Profile S value 
    702                      IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    703                         & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    704                         profdata%var(2)%vobs(is3dt) = & 
    705                            &                inpfiles(jj)%pob(ij,ji,2) 
    706                         IF ( ldmod ) THEN 
    707                            profdata%var(2)%vmod(is3dt) = & 
    708                               &                inpfiles(jj)%padd(ij,ji,1,2) 
    709                         ENDIF 
    710                         ! Count number of profile S data as function of type 
    711                         ityps( profdata%ntyp(iprof) + 1 ) = & 
    712                            & ityps( profdata%ntyp(iprof) + 1 ) + 1 
    713                      ELSE 
    714                         profdata%var(2)%vobs(is3dt) = fbrmdi 
    715                      ENDIF 
    716                       
    717                      ! Profile S qc 
    718                      profdata%var(2)%nvqc(is3dt) = & 
    719                         & inpfiles(jj)%ivlqc(ij,ji,2) 
    720  
    721                      ! Profile S qc flags 
    722                      profdata%var(2)%nvqcf(:,is3dt) = & 
    723                         & inpfiles(jj)%ivlqcf(:,ij,ji,2) 
    724  
    725                   ENDIF 
    726              
     731                  END DO 
     732 
    727733               END DO loop_p 
    728734 
    … …  
    736742      ! Sum up over processors 
    737743      !----------------------------------------------------------------------- 
    738        
    739       CALL obs_mpp_sum_integer ( it3dt0, it3dtmpp ) 
    740       CALL obs_mpp_sum_integer ( is3dt0, is3dtmpp ) 
    741       CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) 
    742        
    743       CALL obs_mpp_sum_integers( itypt, ityptmpp, ntyp1770 + 1 ) 
    744       CALL obs_mpp_sum_integers( ityps, itypsmpp, ntyp1770 + 1 ) 
    745        
     744 
     745      DO jvar = 1, kvars 
     746         CALL obs_mpp_sum_integer ( ivart0(jvar), ivartmpp(jvar) ) 
     747      END DO 
     748      CALL obs_mpp_sum_integer ( ip3dt,   ip3dtmpp  ) 
     749 
     750      DO jvar = 1, kvars 
     751         CALL obs_mpp_sum_integers( itypvar(:,jvar), itypvarmpp(:,jvar), ntyp1770 + 1 ) 
     752      END DO 
     753 
    746754      !----------------------------------------------------------------------- 
    747755      ! Output number of observations. 
    … …  
    749757      IF(lwp) THEN 
    750758         WRITE(numout,*)  
    751          WRITE(numout,'(1X,A)') 'Profile data' 
     759         WRITE(numout,'(A)') ' Profile data' 
    752760         WRITE(numout,'(1X,A)') '------------' 
    753761         WRITE(numout,*)  
    754          WRITE(numout,'(1X,A)') 'Profile T data' 
    755          WRITE(numout,'(1X,A)') '--------------' 
    756          DO ji = 0, ntyp1770 
    757             IF ( ityptmpp(ji+1) > 0 ) THEN 
    758                WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
    759                   & cwmonam1770(ji)(1:52),' = ', & 
    760                   & ityptmpp(ji+1) 
    761             ENDIF 
     762         DO jvar = 1, kvars 
     763            WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(jvar) ) 
     764            WRITE(numout,'(1X,A)') '------------------------' 
     765            DO ji = 0, ntyp1770 
     766               IF ( itypvarmpp(ji+1,jvar) > 0 ) THEN 
     767                  WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
     768                     & cwmonam1770(ji)(1:52),' = ', & 
     769                     & itypvarmpp(ji+1,jvar) 
     770               ENDIF 
     771            END DO 
     772            WRITE(numout,'(1X,A)') & 
     773               & '---------------------------------------------------------------' 
     774            WRITE(numout,'(1X,A55,I8)') & 
     775               & 'Total profile data for variable '//TRIM( profdata%cvars(jvar) )// & 
     776               & '             = ', ivartmpp(jvar) 
     777            WRITE(numout,'(1X,A)') & 
     778               & '---------------------------------------------------------------' 
     779            WRITE(numout,*)  
    762780         END DO 
    763          WRITE(numout,'(1X,A)') & 
    764             & '---------------------------------------------------------------' 
    765          WRITE(numout,'(1X,A55,I8)') & 
    766             & 'Total profile T data                                 = ',& 
    767             & it3dtmpp 
    768          WRITE(numout,'(1X,A)') & 
    769             & '---------------------------------------------------------------' 
    770          WRITE(numout,*)  
    771          WRITE(numout,'(1X,A)') 'Profile S data' 
    772          WRITE(numout,'(1X,A)') '--------------' 
    773          DO ji = 0, ntyp1770 
    774             IF ( itypsmpp(ji+1) > 0 ) THEN 
    775                WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
    776                   & cwmonam1770(ji)(1:52),' = ', & 
    777                   & itypsmpp(ji+1) 
    778             ENDIF 
     781      ENDIF 
     782 
     783      IF (ldsatt) THEN 
     784         profdata%nvprot(:)    = ip3dt 
     785         profdata%nvprotmpp(:) = ip3dtmpp 
     786      ELSE 
     787         DO jvar = 1, kvars 
     788            profdata%nvprot(jvar)    = ivart(jvar) 
     789            profdata%nvprotmpp(jvar) = ivartmpp(jvar) 
    779790         END DO 
    780          WRITE(numout,'(1X,A)') & 
    781             & '---------------------------------------------------------------' 
    782          WRITE(numout,'(1X,A55,I8)') & 
    783             & 'Total profile S data                                 = ',& 
    784             & is3dtmpp 
    785          WRITE(numout,'(1X,A)') & 
    786             & '---------------------------------------------------------------' 
    787          WRITE(numout,*)  
    788       ENDIF 
    789        
    790       IF (ldsatt) THEN 
    791          profdata%nvprot(1)    = ip3dt 
    792          profdata%nvprot(2)    = ip3dt 
    793          profdata%nvprotmpp(1) = ip3dtmpp 
    794          profdata%nvprotmpp(2) = ip3dtmpp 
    795       ELSE 
    796          profdata%nvprot(1)    = it3dt 
    797          profdata%nvprot(2)    = is3dt 
    798          profdata%nvprotmpp(1) = it3dtmpp 
    799          profdata%nvprotmpp(2) = is3dtmpp 
    800791      ENDIF 
    801792      profdata%nprof        = iprof 
    … …  
    804795      ! Model level search 
    805796      !----------------------------------------------------------------------- 
    806       IF ( ldt3d ) THEN 
    807          CALL obs_level_search( jpk, gdept_1d, & 
    808             & profdata%nvprot(1), profdata%var(1)%vdep, & 
    809             & profdata%var(1)%mvk ) 
    810       ENDIF 
    811       IF ( lds3d ) THEN 
    812          CALL obs_level_search( jpk, gdept_1d, & 
    813             & profdata%nvprot(2), profdata%var(2)%vdep, & 
    814             & profdata%var(2)%mvk ) 
    815       ENDIF 
    816        
     797      DO jvar = 1, kvars 
     798         IF ( ldvar(jvar) ) THEN 
     799            CALL obs_level_search( jpk, gdept_1d, & 
     800               & profdata%nvprot(jvar), profdata%var(jvar)%vdep, & 
     801               & profdata%var(jvar)%mvk ) 
     802         ENDIF 
     803      END DO 
     804 
    817805      !----------------------------------------------------------------------- 
    818806      ! Set model equivalent to 99999 
    … …  
    826814      ! Deallocate temporary data 
    827815      !----------------------------------------------------------------------- 
    828       DEALLOCATE( ifileidx, iprofidx, zdat ) 
     816      DEALLOCATE( ifileidx, iprofidx, zdat, clvarsin ) 
    829817 
    830818      !----------------------------------------------------------------------- 
    … …  
    836824      DEALLOCATE( inpfiles ) 
    837825 
    838    END SUBROUTINE obs_rea_pro_dri 
     826   END SUBROUTINE obs_rea_prof 
    839827 
    840828END MODULE obs_read_prof 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readmdt.F90

    r8058 r15670  
    3131   PRIVATE 
    3232    
    33    PUBLIC   obs_rea_mdt     ! called by ? 
    34    PUBLIC   obs_offset_mdt  ! called by ? 
    35  
    36    INTEGER , PUBLIC ::   nmsshc    = 1         ! MDT correction scheme 
    37    REAL(wp), PUBLIC ::   mdtcorr   = 1.61_wp   ! User specified MDT correction 
    38    REAL(wp), PUBLIC ::   mdtcutoff = 65.0_wp   ! MDT cutoff for computed correction 
     33   PUBLIC   obs_rea_mdt     ! called by dia_obs_init 
     34   PUBLIC   obs_offset_mdt  ! called by obs_rea_mdt 
     35 
     36   INTEGER , PUBLIC :: nn_msshc    = 1         ! MDT correction scheme 
     37   REAL(wp), PUBLIC :: rn_mdtcorr   = 1.61_wp  ! User specified MDT correction 
     38   REAL(wp), PUBLIC :: rn_mdtcutoff = 65.0_wp  ! MDT cutoff for computed correction 
    3939 
    4040   !!---------------------------------------------------------------------- 
    … …  
    4545CONTAINS 
    4646 
    47    SUBROUTINE obs_rea_mdt( kslano, sladata, k2dint ) 
     47   SUBROUTINE obs_rea_mdt( sladata, k2dint ) 
    4848      !!--------------------------------------------------------------------- 
    4949      !! 
    … …  
    5858      USE iom 
    5959      ! 
    60       INTEGER                          , INTENT(IN)    ::   kslano    ! Number of SLA Products 
    61       TYPE(obs_surf), DIMENSION(kslano), INTENT(inout) ::   sladata   ! SLA data 
    62       INTEGER                          , INTENT(in)    ::   k2dint    ! ? 
     60      TYPE(obs_surf), INTENT(inout) ::   sladata   ! SLA data 
     61      INTEGER       , INTENT(in)    ::   k2dint    ! ? 
    6362      ! 
    6463      CHARACTER(LEN=12), PARAMETER ::   cpname  = 'obs_rea_mdt' 
    6564      CHARACTER(LEN=20), PARAMETER ::   mdtname = 'slaReferenceLevel.nc' 
    6665 
    67       INTEGER ::   jslano              ! Data set loop variable 
    6866      INTEGER ::   jobs                ! Obs loop variable 
    6967      INTEGER ::   jpimdt, jpjmdt      ! Number of grid point in lat/lon for the MDT 
    … …  
    8886      IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies' 
    8987      IF(lwp)WRITE(numout,*) ' ------------- ' 
     88      CALL FLUSH(numout) 
    9089 
    9190      CALL iom_open( mdtname, nummdt )       ! Open the file 
    … …  
    109108 
    110109      ! Remove the offset between the MDT used with the sla and the model MDT 
    111       IF( nmsshc == 1 .OR. nmsshc == 2 )   CALL obs_offset_mdt( z_mdt, zfill ) 
     110      IF( nn_msshc == 1 .OR. nn_msshc == 2 ) & 
     111         & CALL obs_offset_mdt( jpi, jpj, z_mdt, zfill ) 
    112112 
    113113      ! Intepolate the MDT already on the model grid at the observation point 
    114114   
    115       DO jslano = 1, kslano 
    116          ALLOCATE( & 
    117             & igrdi(2,2,sladata(jslano)%nsurf), & 
    118             & igrdj(2,2,sladata(jslano)%nsurf), & 
    119             & zglam(2,2,sladata(jslano)%nsurf), & 
    120             & zgphi(2,2,sladata(jslano)%nsurf), & 
    121             & zmask(2,2,sladata(jslano)%nsurf), & 
    122             & zmdtl(2,2,sladata(jslano)%nsurf)  & 
    123             & ) 
     115      ALLOCATE( & 
     116         & igrdi(2,2,sladata%nsurf), & 
     117         & igrdj(2,2,sladata%nsurf), & 
     118         & zglam(2,2,sladata%nsurf), & 
     119         & zgphi(2,2,sladata%nsurf), & 
     120         & zmask(2,2,sladata%nsurf), & 
     121         & zmdtl(2,2,sladata%nsurf)  & 
     122         & ) 
    124123          
    125          DO jobs = 1, sladata(jslano)%nsurf 
    126  
    127             igrdi(1,1,jobs) = sladata(jslano)%mi(jobs)-1 
    128             igrdj(1,1,jobs) = sladata(jslano)%mj(jobs)-1 
    129             igrdi(1,2,jobs) = sladata(jslano)%mi(jobs)-1 
    130             igrdj(1,2,jobs) = sladata(jslano)%mj(jobs) 
    131             igrdi(2,1,jobs) = sladata(jslano)%mi(jobs) 
    132             igrdj(2,1,jobs) = sladata(jslano)%mj(jobs)-1 
    133             igrdi(2,2,jobs) = sladata(jslano)%mi(jobs) 
    134             igrdj(2,2,jobs) = sladata(jslano)%mj(jobs) 
    135  
    136          END DO 
    137  
    138          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, glamt  , zglam ) 
    139          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, gphit  , zgphi ) 
    140          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, mdtmask, zmask ) 
    141          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, z_mdt  , zmdtl ) 
    142  
    143          DO jobs = 1, sladata(jslano)%nsurf 
     124      DO jobs = 1, sladata%nsurf 
     125 
     126         igrdi(1,1,jobs) = sladata%mi(jobs)-1 
     127         igrdj(1,1,jobs) = sladata%mj(jobs)-1 
     128         igrdi(1,2,jobs) = sladata%mi(jobs)-1 
     129         igrdj(1,2,jobs) = sladata%mj(jobs) 
     130         igrdi(2,1,jobs) = sladata%mi(jobs) 
     131         igrdj(2,1,jobs) = sladata%mj(jobs)-1 
     132         igrdi(2,2,jobs) = sladata%mi(jobs) 
     133         igrdj(2,2,jobs) = sladata%mj(jobs) 
     134 
     135      END DO 
     136 
     137      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, glamt  , zglam ) 
     138      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, gphit  , zgphi ) 
     139      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, mdtmask, zmask ) 
     140      CALL obs_int_comm_2d( 2, 2, sladata%nsurf, jpi, jpj, igrdi, igrdj, z_mdt  , zmdtl ) 
     141 
     142      DO jobs = 1, sladata%nsurf 
    144143             
    145             zlam = sladata(jslano)%rlam(jobs) 
    146             zphi = sladata(jslano)%rphi(jobs) 
    147  
    148             CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
    149                &                   zglam(:,:,jobs), zgphi(:,:,jobs), & 
    150                &                   zmask(:,:,jobs), zweig, zobsmask ) 
     144         zlam = sladata%rlam(jobs) 
     145         zphi = sladata%rphi(jobs) 
     146 
     147         CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
     148            &                   zglam(:,:,jobs), zgphi(:,:,jobs), & 
     149            &                   zmask(:,:,jobs), zweig, zobsmask ) 
    151150             
    152             CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs),  zext ) 
     151         CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs),  zext ) 
    153152  
    154             sladata(jslano)%rext(jobs,2) = zext(1) 
     153         sladata%rext(jobs,2) = zext(1) 
    155154 
    156155! mark any masked data with a QC flag 
    157             IF( zobsmask(1) == 0 )   sladata(jslano)%nqc(jobs) = 11 
     156         IF( zobsmask(1) == 0 )   sladata%nqc(jobs) = IBSET(sladata%nqc(jobs),15) 
    158157 
    159158         END DO 
    160159          
    161          DEALLOCATE( & 
    162             & igrdi, & 
    163             & igrdj, & 
    164             & zglam, & 
    165             & zgphi, & 
    166             & zmask, & 
    167             & zmdtl  & 
    168             & ) 
    169  
    170       END DO 
     160      DEALLOCATE( & 
     161         & igrdi, & 
     162         & igrdj, & 
     163         & zglam, & 
     164         & zgphi, & 
     165         & zmask, & 
     166         & zmdtl  & 
     167         & ) 
    171168 
    172169      CALL wrk_dealloc(jpi,jpj,z_mdt,mdtmask)  
     170      IF(lwp)WRITE(numout,*) ' ------------- ' 
    173171      ! 
    174172   END SUBROUTINE obs_rea_mdt 
    175173 
    176174 
    177    SUBROUTINE obs_offset_mdt( mdt, zfill ) 
     175   SUBROUTINE obs_offset_mdt( kpi, kpj, mdt, zfill ) 
    178176      !!--------------------------------------------------------------------- 
    179177      !! 
    … …  
    188186      !! ** Action  :  
    189187      !!---------------------------------------------------------------------- 
    190       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   mdt     ! MDT used on the model grid 
    191       REAL(wp)                    , INTENT(in   ) ::   zfill  
     188      INTEGER, INTENT(IN) ::  kpi, kpj 
     189      REAL(wp), DIMENSION(kpi,kpj), INTENT(INOUT) ::   mdt     ! MDT used on the model grid 
     190      REAL(wp)                    , INTENT(IN   ) ::   zfill  
    192191      !  
    193192      INTEGER  :: ji, jj 
    … …  
    205204        DO jj = 1, jpj 
    206205           zpromsk(ji,jj) = tmask_i(ji,jj) 
    207            IF (    ( gphit(ji,jj) .GT.  mdtcutoff ) & 
    208               &.OR.( gphit(ji,jj) .LT. -mdtcutoff ) & 
     206           IF (    ( gphit(ji,jj) .GT.  rn_mdtcutoff ) & 
     207              &.OR.( gphit(ji,jj) .LT. -rn_mdtcutoff ) & 
    209208              &.OR.( mdt(ji,jj) .EQ. zfill ) ) & 
    210209              &        zpromsk(ji,jj) = 0.0 
    … …  
    212211      END DO  
    213212 
    214       ! Compute MSSH mean over [0,360] x [-mdtcutoff,mdtcutoff] 
     213      ! Compute MSSH mean over [0,360] x [-rn_mdtcutoff,rn_mdtcutoff] 
    215214 
    216215      zarea = 0.0 
    … …  
    240239      !  Correct spatial mean of the MSSH 
    241240 
    242       IF( nmsshc == 1 )   mdt(:,:) = mdt(:,:) - zcorr   
     241      IF( nn_msshc == 1 )   mdt(:,:) = mdt(:,:) - zcorr   
    243242 
    244243      ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT 
    245244 
    246       IF( nmsshc == 2 )   mdt(:,:) = mdt(:,:) - mdtcorr 
     245      IF( nn_msshc == 2 )   mdt(:,:) = mdt(:,:) - rn_mdtcorr 
    247246 
    248247      IF(lwp) THEN 
    249248         WRITE(numout,*) 
    250          WRITE(numout,*) ' obs_readmdt : mdtcutoff     = ', mdtcutoff 
     249         WRITE(numout,*) ' obs_readmdt : rn_mdtcutoff     = ', rn_mdtcutoff 
    251250         WRITE(numout,*) ' -----------   zcorr_mdt     = ', zcorr_mdt 
    252251         WRITE(numout,*) '               zcorr_bcketa  = ', zcorr_bcketa 
    253252         WRITE(numout,*) '               zcorr         = ', zcorr 
    254          WRITE(numout,*) '               nmsshc        = ', nmsshc 
     253         WRITE(numout,*) '               nn_msshc        = ', nn_msshc 
    255254      ENDIF 
    256255 
    257       IF ( nmsshc == 0 ) WRITE(numout,*) '           MSSH correction is not applied' 
    258       IF ( nmsshc == 1 ) WRITE(numout,*) '           MSSH correction is applied' 
    259       IF ( nmsshc == 2 ) WRITE(numout,*) '           User defined MSSH correction'  
     256      IF ( nn_msshc == 0 ) WRITE(numout,*) '           MSSH correction is not applied' 
     257      IF ( nn_msshc == 1 ) WRITE(numout,*) '           MSSH correction is applied' 
     258      IF ( nn_msshc == 2 ) WRITE(numout,*) '           User defined MSSH correction'  
    260259 
    261260      CALL wrk_dealloc( jpi,jpj, zpromsk ) 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90

    r8058 r15670  
    140140      END DO 
    141141 
    142       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
     142      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 
    143143         &                  glamu, zglamu ) 
    144       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
     144      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 
    145145         &                  gphiu, zgphiu ) 
    146       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
     146      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 
    147147         &                  umask(:,:,1), zmasku ) 
    148       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
     148      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 
    149149         &                  zsingu, zsinlu ) 
    150       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
     150      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiu, igrdju, & 
    151151         &                  zcosgu, zcoslu ) 
    152       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
     152      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 
    153153         &                  glamv, zglamv ) 
    154       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
     154      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 
    155155         &                  gphiv, zgphiv ) 
    156       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
     156      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 
    157157         &                  vmask(:,:,1), zmaskv ) 
    158       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
     158      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 
    159159         &                  zsingv, zsinlv ) 
    160       CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
     160      CALL obs_int_comm_2d( 2, 2, profdata%nprof, jpi, jpj, igrdiv, igrdjv, & 
    161161         &                  zcosgv, zcoslv ) 
    162162 
    … …  
    195195         DO jk = profdata%npvsta(ji,1), profdata%npvend(ji,1) 
    196196            IF ( ( profdata%var(1)%vmod(jk) /= fbrmdi ) .AND. & 
    197                & ( profdata%var(1)%vmod(jk) /= fbrmdi ) ) THEN 
     197               & ( profdata%var(2)%vmod(jk) /= fbrmdi ) ) THEN 
    198198               pu(jk) = profdata%var(1)%vmod(jk) * zcos - & 
    199                   &     profdata%var(2)%vmod(jk) * zsin  
     199                  &     profdata%var(2)%vmod(jk) * zsin 
    200200               pv(jk) = profdata%var(2)%vmod(jk) * zcos + & 
    201201                  &     profdata%var(1)%vmod(jk) * zsin 
    … …  
    204204               pv(jk) = fbrmdi 
    205205            ENDIF 
     206 
    206207         END DO 
    207208 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_surf_def.F90

    r8058 r15670  
    5050      INTEGER :: npj 
    5151      INTEGER :: nsurfup    !: Observation counter used in obs_oper 
    52  
     52      INTEGER :: nrec       !: Number of surface observation records in window 
     53 
     54      LOGICAL :: lclim      !: Climatology will be calculated for this structure 
     55       
    5356      ! Arrays with size equal to the number of surface observations 
    5457 
    … …  
    5659         & mi,   &        !: i-th grid coord. for interpolating to surface observation 
    5760         & mj,   &        !: j-th grid coord. for interpolating to surface observation 
     61         & mt,   &        !: time record number for gridded data 
    5862         & nsidx,&        !: Surface observation number 
    5963         & nsfil,&        !: Surface observation number in file 
    … …  
    6771         & ntyp           !: Type of surface observation product 
    6872 
     73      CHARACTER(len=8), POINTER, DIMENSION(:) :: & 
     74         & cvars          !: Variable names 
     75 
     76      CHARACTER(len=8), POINTER, DIMENSION(:) :: & 
     77         & cext           !: Extra field names 
     78 
    6979      CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & 
    7080         & cwmo           !: WMO indentifier 
    … …  
    7686      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
    7787         & robs, &        !: Surface observation  
    78          & rmod           !: Model counterpart of the surface observation vector 
    79  
     88         & rmod, &        !: Model counterpart of the surface observation vector 
     89         & rclm           !: Climatological counterpart of the surface observation vector 
     90          
    8091      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
    8192         & rext           !: Extra fields interpolated to observation points 
    … …  
    90101         & nsstpmpp       !: Global number of surface observations per time step 
    91102 
     103      ! Arrays with size equal to the number of observation records in the window 
     104      INTEGER, POINTER, DIMENSION(:) :: & 
     105         & mrecstp   ! Time step of the records 
     106 
    92107      ! Arrays used to store source indices when  
    93108      ! compressing obs_surf derived types 
    … …  
    97112      INTEGER, POINTER, DIMENSION(:) :: & 
    98113         & nsind          !: Source indices of surface data in compressed data 
     114 
     115      ! Is this a gridded product? 
     116      
     117      LOGICAL :: lgrid 
    99118 
    100119   END TYPE obs_surf 
    … …  
    108127CONTAINS 
    109128    
    110    SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kextra, kstp, kpi, kpj ) 
     129   SUBROUTINE obs_surf_alloc( surf, ksurf, kvar, kextra, kstp, kpi, kpj, ldclim ) 
    111130      !!---------------------------------------------------------------------- 
    112131      !!                     ***  ROUTINE obs_surf_alloc  *** 
    … …  
    127146      INTEGER, INTENT(IN) :: kpi     ! Number of 3D grid points 
    128147      INTEGER, INTENT(IN) :: kpj 
     148      LOGICAL, INTENT(IN) :: ldclim   
    129149 
    130150      !!* Local variables 
    131151      INTEGER :: ji 
     152      INTEGER :: jvar 
    132153 
    133154      ! Set bookkeeping variables 
    … …  
    140161      surf%npi      = kpi 
    141162      surf%npj      = kpj 
     163      surf%lclim    = ldclim 
     164 
     165      ! Allocate arrays of size number of variables 
     166 
     167      ALLOCATE( & 
     168         & surf%cvars(kvar)    & 
     169         & ) 
     170 
     171      DO jvar = 1, kvar 
     172         surf%cvars(jvar) = "NotSet" 
     173      END DO 
    142174       
    143175      ! Allocate arrays of number of surface data size 
    … …  
    146178         & surf%mi(ksurf),      & 
    147179         & surf%mj(ksurf),      & 
     180         & surf%mt(ksurf),      & 
    148181         & surf%nsidx(ksurf),   & 
    149182         & surf%nsfil(ksurf),   & 
    … …  
    162195         & ) 
    163196 
     197      surf%mt(:) = -1 
     198 
    164199 
    165200      ! Allocate arrays of number of surface data size * number of variables 
    … …  
    167202      ALLOCATE( &  
    168203         & surf%robs(ksurf,kvar), & 
    169          & surf%rmod(ksurf,kvar)  & 
     204         & surf%rmod(ksurf,kvar) & 
    170205         & )    
    171206 
     207      IF (surf%lclim) ALLOCATE( surf%rclm(ksurf,kvar) ) 
     208       
    172209      ! Allocate arrays of number of extra fields at observation points 
    173210 
    174211      ALLOCATE( &  
    175          & surf%rext(ksurf,kextra) & 
    176          & ) 
     212         & surf%rext(ksurf,kextra), & 
     213         & surf%cext(kextra)        & 
     214         & ) 
     215 
     216      surf%rext(:,:) = 0.0_wp  
     217 
     218      DO ji = 1, kextra 
     219         surf%cext(ji) = "NotSet" 
     220      END DO 
    177221 
    178222      ! Allocate arrays of number of time step size 
    … …  
    203247 
    204248      surf%nsurfup     = 0 
     249       
     250      ! Not gridded by default 
     251           
     252      surf%lgrid       = .FALSE. 
    205253               
    206254   END SUBROUTINE obs_surf_alloc 
    … …  
    228276         & surf%mi,      & 
    229277         & surf%mj,      & 
     278         & surf%mt,      & 
    230279         & surf%nsidx,   & 
    231280         & surf%nsfil,   & 
    … …  
    251300         & ) 
    252301 
     302      IF (surf%lclim) DEALLOCATE( surf%rclm ) 
    253303      ! Deallocate arrays of number of extra fields at observation points 
    254304 
    255305      DEALLOCATE( &  
    256          & surf%rext & 
     306         & surf%rext, & 
     307         & surf%cext & 
    257308         & ) 
    258309 
    … …  
    269320         & surf%nsstp,     & 
    270321         & surf%nsstpmpp   & 
     322         & ) 
     323 
     324      ! Dellocate arrays of size number of variables 
     325 
     326      DEALLOCATE( & 
     327         & surf%cvars     & 
    271328         & ) 
    272329 
    … …  
    322379      IF ( lallocate ) THEN 
    323380         CALL obs_surf_alloc( newsurf,  insurf, surf%nvar, & 
    324             & surf%nextra, surf%nstp, surf%npi, surf%npj ) 
     381            & surf%nextra, surf%nstp, surf%npi, surf%npj, surf%lclim ) 
    325382      ENDIF 
    326383 
    … …  
    350407            newsurf%mi(insurf)    = surf%mi(ji) 
    351408            newsurf%mj(insurf)    = surf%mj(ji) 
     409            newsurf%mt(insurf)    = surf%mt(ji) 
    352410            newsurf%nsidx(insurf) = surf%nsidx(ji) 
    353411            newsurf%nsfil(insurf) = surf%nsfil(ji) 
    … …  
    368426               newsurf%robs(insurf,jk)  = surf%robs(ji,jk) 
    369427               newsurf%rmod(insurf,jk)  = surf%rmod(ji,jk) 
     428               IF (newsurf%lclim) newsurf%rclm(insurf,jk) = surf%rclm(ji,jk)  
    370429                
    371430            END DO 
    … …  
    392451      ! Set book keeping variables which do not depend on number of obs. 
    393452 
    394       newsurf%nstp  = surf%nstp 
     453      newsurf%nstp     = surf%nstp 
     454      newsurf%cvars(:) = surf%cvars(:) 
     455      newsurf%cext(:)  = surf%cext(:) 
     456       
     457      ! Set gridded stuff 
     458       
     459      newsurf%mt(insurf)    = surf%mt(ji) 
    395460  
    396461      ! Deallocate temporary data 
    … …  
    433498         oldsurf%mi(jj)    = surf%mi(ji) 
    434499         oldsurf%mj(jj)    = surf%mj(ji) 
     500         oldsurf%mt(jj)    = surf%mt(ji) 
    435501         oldsurf%nsidx(jj) = surf%nsidx(ji) 
    436502         oldsurf%nsfil(jj) = surf%nsfil(ji) 
    … …  
    457523            oldsurf%robs(jj,jk)  = surf%robs(ji,jk) 
    458524            oldsurf%rmod(jj,jk)  = surf%rmod(ji,jk) 
     525            IF (surf%lclim) oldsurf%rclm(jj,jk)  = surf%rclm(ji,jk)             
    459526 
    460527         END DO 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_types.F90

    r8058 r15670  
    117117 
    118118         cwmonam1770(ji) = 'Not defined' 
    119          ctypshort(ji) = 'XBT' 
     119         ctypshort(ji) = '---' 
    120120 
    121121!         IF ( ji < 1000 ) THEN 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90

    r8058 r15670  
    66 
    77   !!---------------------------------------------------------------------- 
    8    !!   obs_wri_p3d   : Write profile observation diagnostics in NetCDF format 
    9    !!   obs_wri_sla   : Write SLA observation related diagnostics 
    10    !!   obs_wri_sst   : Write SST observation related diagnostics 
    11    !!   obs_wri_seaice: Write seaice observation related diagnostics 
    12    !!   obs_wri_vel   : Write velocity observation diagnostics in NetCDF format 
    13    !!   obs_wri_stats : Print basic statistics on the data being written out 
     8   !!   obs_wri_prof   : Write profile observations in feedback format 
     9   !!   obs_wri_surf   : Write surface observations in feedback format 
     10   !!   obs_wri_stats  : Print basic statistics on the data being written out 
    1411   !!---------------------------------------------------------------------- 
    1512 
    … …  
    3027   USE obs_conv             ! Conversion between units 
    3128   USE obs_const 
    32    USE obs_sla_types 
    33    USE obs_rot_vel          ! Rotation of velocities 
    3429   USE obs_mpp              ! MPP support routines for observation diagnostics 
    3530   USE lib_mpp        ! MPP routines 
    … …  
    3934   !! * Routine accessibility 
    4035   PRIVATE 
    41    PUBLIC obs_wri_p3d, &    ! Write profile observation related diagnostics 
    42       &   obs_wri_sla, &    ! Write SLA observation related diagnostics 
    43       &   obs_wri_sst, &    ! Write SST observation related diagnostics 
    44       &   obs_wri_sss, &    ! Write SSS observation related diagnostics 
    45       &   obs_wri_seaice, & ! Write seaice observation related diagnostics 
    46       &   obs_wri_vel, &    ! Write velocity observation related diagnostics 
     36   PUBLIC obs_wri_prof, &    ! Write profile observation files 
     37      &   obs_wri_surf, &    ! Write surface observation files 
    4738      &   obswriinfo 
    4839    
    … …  
    6354CONTAINS 
    6455 
    65    SUBROUTINE obs_wri_p3d( cprefix, profdata, padd, pext ) 
     56   SUBROUTINE obs_wri_prof( profdata, padd, pext ) 
    6657      !!----------------------------------------------------------------------- 
    6758      !! 
    68       !!                     *** ROUTINE obs_wri_p3d  *** 
    69       !! 
    70       !! ** Purpose : Write temperature and salinity (profile) observation  
    71       !!              related diagnostics 
     59      !!                     *** ROUTINE obs_wri_prof  *** 
     60      !! 
     61      !! ** Purpose : Write profile feedback files 
    7262      !! 
    7363      !! ** Method  : NetCDF 
    … …  
    8272      !!      ! 07-03  (K. Mogensen) General handling of profiles 
    8373      !!      ! 09-01  (K. Mogensen) New feedback format 
     74      !!      ! 15-02  (M. Martin) Combined routine for writing profiles 
    8475      !!----------------------------------------------------------------------- 
    8576 
    86       !! * Modules used 
    87  
    8877      !! * Arguments 
    89       CHARACTER(LEN=*), INTENT(IN) :: cprefix        ! Prefix for output files 
    9078      TYPE(obs_prof), INTENT(INOUT) :: profdata      ! Full set of profile data 
    9179      TYPE(obswriinfo), OPTIONAL :: padd             ! Additional info for each variable 
    9280      TYPE(obswriinfo), OPTIONAL :: pext             ! Extra info 
    93        
     81 
    9482      !! * Local declarations 
    9583      TYPE(obfbdata) :: fbdata 
    96       CHARACTER(LEN=40) :: cfname 
     84      CHARACTER(LEN=40) :: clfname 
     85      CHARACTER(LEN=10) :: clfiletype 
     86      CHARACTER(LEN=ilenlong) :: cllongname  ! Long name of variable 
     87      CHARACTER(LEN=ilenunit) :: clunits     ! Units of variable 
     88      CHARACTER(LEN=ilengrid) :: clgrid      ! Grid of variable 
    9789      INTEGER :: ilevel 
    9890      INTEGER :: jvar 
    … …  
    10294      INTEGER :: ja 
    10395      INTEGER :: je 
     96      INTEGER :: iadd 
     97      INTEGER :: iadd_clm ! 1 if climatology present 
     98      INTEGER :: iext 
    10499      REAL(wp) :: zpres 
    105       INTEGER :: nadd 
    106       INTEGER :: next 
    107  
     100 
     101 
     102      iadd_clm = 0  
     103      IF ( profdata%lclim ) iadd_clm = 1 
     104       
    108105      IF ( PRESENT( padd ) ) THEN 
    109          nadd = padd%inum 
     106         iadd = padd%inum 
    110107      ELSE 
    111          nadd = 0 
     108         iadd = 0 
    112109      ENDIF 
    113110 
    114111      IF ( PRESENT( pext ) ) THEN 
    115          next = pext%inum 
     112         iext = pext%inum 
    116113      ELSE 
    117          next = 0 
    118       ENDIF 
    119        
     114         iext = 0 
     115      ENDIF 
     116 
    120117      CALL init_obfbdata( fbdata ) 
    121118 
    122119      ! Find maximum level 
    123120      ilevel = 0 
    124       DO jvar = 1, 2 
     121      DO jvar = 1, profdata%nvar 
    125122         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 
    126123      END DO 
    127       CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 
    128          &                 1 + nadd, 1 + next, .TRUE. ) 
    129  
    130       fbdata%cname(1)      = 'POTM' 
    131       fbdata%cname(2)      = 'PSAL' 
    132       fbdata%coblong(1)    = 'Potential temperature' 
    133       fbdata%coblong(2)    = 'Practical salinity' 
    134       fbdata%cobunit(1)    = 'Degrees centigrade' 
    135       fbdata%cobunit(2)    = 'PSU' 
    136       fbdata%cextname(1)   = 'TEMP' 
    137       fbdata%cextlong(1)   = 'Insitu temperature' 
    138       fbdata%cextunit(1)   = 'Degrees centigrade' 
    139       DO je = 1, next 
    140          fbdata%cextname(1+je) = pext%cdname(je) 
    141          fbdata%cextlong(1+je) = pext%cdlong(je,1) 
    142          fbdata%cextunit(1+je) = pext%cdunit(je,1) 
    143       END DO 
     124 
     125      SELECT CASE ( TRIM(profdata%cvars(1)) ) 
     126      CASE('POTM') 
     127 
     128         clfiletype='profb' 
     129         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 
     130            &                 1 + iadd_clm + iadd, 1 + iext, .TRUE. ) 
     131         fbdata%cname(1)      = profdata%cvars(1) 
     132         fbdata%cname(2)      = profdata%cvars(2) 
     133         fbdata%coblong(1)    = 'Potential temperature' 
     134         fbdata%coblong(2)    = 'Practical salinity' 
     135         fbdata%cobunit(1)    = 'Degrees centigrade' 
     136         fbdata%cobunit(2)    = 'PSU' 
     137         fbdata%cextname(1)   = 'TEMP' 
     138         fbdata%cextlong(1)   = 'Insitu temperature' 
     139         fbdata%cextunit(1)   = 'Degrees centigrade' 
     140         fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 
     141         fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 
     142         fbdata%caddunit(1,1) = 'Degrees centigrade' 
     143         fbdata%caddunit(1,2) = 'PSU' 
     144         IF ( profdata%lclim ) THEN 
     145            fbdata%caddlong(2,1) = 'Climatology interpolated potential temperature' 
     146            fbdata%caddlong(2,2) = 'Climatology interpolated practical salinity' 
     147            fbdata%caddunit(2,1) = 'Degrees centigrade' 
     148            fbdata%caddunit(2,2) = 'PSU' 
     149         ENDIF 
     150         fbdata%cgrid(:)      = 'T' 
     151         DO je = 1, iext 
     152            fbdata%cextname(1+je) = pext%cdname(je) 
     153            fbdata%cextlong(1+je) = pext%cdlong(je,1) 
     154            fbdata%cextunit(1+je) = pext%cdunit(je,1) 
     155         END DO 
     156         DO ja = 1, iadd 
     157            fbdata%caddname(1+iadd_clm+ja) = padd%cdname(ja) 
     158            DO jvar = 1, 2 
     159               fbdata%caddlong(1+iadd_clm+ja,jvar) = padd%cdlong(ja,jvar) 
     160               fbdata%caddunit(1+iadd_clm+ja,jvar) = padd%cdunit(ja,jvar) 
     161            END DO 
     162         END DO 
     163 
     164      CASE('UVEL') 
     165 
     166         clfiletype='velfb' 
     167         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 
     168            &                 1 + iadd_clm + iadd, 0, .TRUE. ) 
     169         fbdata%cname(1)      = profdata%cvars(1) 
     170         fbdata%cname(2)      = profdata%cvars(2) 
     171         fbdata%coblong(1)    = 'Zonal velocity' 
     172         fbdata%coblong(2)    = 'Meridional velocity' 
     173         fbdata%cobunit(1)    = 'm/s' 
     174         fbdata%cobunit(2)    = 'm/s' 
     175         DO je = 1, iext 
     176            fbdata%cextname(je) = pext%cdname(je) 
     177            fbdata%cextlong(je) = pext%cdlong(je,1) 
     178            fbdata%cextunit(je) = pext%cdunit(je,1) 
     179         END DO 
     180         fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 
     181         fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 
     182         fbdata%caddunit(1,1) = 'm/s' 
     183         fbdata%caddunit(1,2) = 'm/s' 
     184         IF ( profdata%lclim ) THEN 
     185            fbdata%caddlong(2,1) = 'Climatology interpolated zonal velocity' 
     186            fbdata%caddlong(2,2) = 'Climatology interpolated meridional velocity' 
     187            fbdata%caddunit(2,1) = 'm/s' 
     188            fbdata%caddunit(2,2) = 'm/s' 
     189         ENDIF          
     190         fbdata%cgrid(1)      = 'U'  
     191         fbdata%cgrid(2)      = 'V' 
     192         DO ja = 1, iadd 
     193            fbdata%caddname(1+iadd_clm+ja) = padd%cdname(ja) 
     194            fbdata%caddlong(1+iadd_clm+ja,1) = padd%cdlong(ja,1) 
     195            fbdata%caddunit(1+iadd_clm+ja,1) = padd%cdunit(ja,1) 
     196         END DO 
     197 
     198      CASE('PLCHLTOT') 
     199 
     200         clfiletype = 'plchltotfb' 
     201         cllongname = 'log10(chlorophyll concentration)' 
     202         clunits    = 'log10(mg/m3)' 
     203         clgrid     = 'T' 
     204 
     205      CASE('PCHLTOT') 
     206 
     207         clfiletype = 'pchltotfb' 
     208         cllongname = 'chlorophyll concentration' 
     209         clunits    = 'mg/m3' 
     210         clgrid     = 'T' 
     211 
     212      CASE('PNO3') 
     213 
     214         clfiletype = 'pno3fb' 
     215         cllongname = 'nitrate' 
     216         clunits    = 'mmol/m3' 
     217         clgrid     = 'T' 
     218 
     219      CASE('PSI4') 
     220 
     221         clfiletype = 'psi4fb' 
     222         cllongname = 'silicate' 
     223         clunits    = 'mmol/m3' 
     224         clgrid     = 'T' 
     225 
     226      CASE('PPO4') 
     227 
     228         clfiletype = 'ppo4fb' 
     229         cllongname = 'phosphate' 
     230         clunits    = 'mmol/m3' 
     231         clgrid     = 'T' 
     232 
     233      CASE('PDIC') 
     234 
     235         clfiletype = 'pdicfb' 
     236         cllongname = 'dissolved inorganic carbon' 
     237         clunits    = 'mmol/m3' 
     238         clgrid     = 'T' 
     239 
     240      CASE('PALK') 
     241 
     242         clfiletype = 'palkfb' 
     243         cllongname = 'alkalinity' 
     244         clunits    = 'meq/m3' 
     245         clgrid     = 'T' 
     246 
     247      CASE('PPH') 
     248 
     249         clfiletype = 'pphfb' 
     250         cllongname = 'pH' 
     251         clunits    = '-' 
     252         clgrid     = 'T' 
     253 
     254      CASE('PO2') 
     255 
     256         clfiletype = 'po2fb' 
     257         cllongname = 'dissolved oxygen' 
     258         clunits    = 'mmol/m3' 
     259         clgrid     = 'T' 
     260 
     261      END SELECT 
     262       
     263      IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 
     264         & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 
     265         CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 
     266            &                 1 + iadd_clm + iadd, iext, .TRUE. ) 
     267         fbdata%cname(1)      = profdata%cvars(1) 
     268         fbdata%coblong(1)    = cllongname 
     269         fbdata%cobunit(1)    = clunits 
     270         fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 
     271         fbdata%caddunit(1,1) = clunits 
     272         IF ( profdata%lclim ) THEN 
     273            fbdata%caddlong(2,1) = 'Climatological interpolated ' // TRIM(cllongname) 
     274            fbdata%caddunit(2,1) = clunits 
     275         ENDIF          
     276         fbdata%cgrid(:)      = clgrid 
     277         DO je = 1, iext 
     278            fbdata%cextname(je) = pext%cdname(je) 
     279            fbdata%cextlong(je) = pext%cdlong(je,1) 
     280            fbdata%cextunit(je) = pext%cdunit(je,1) 
     281         END DO 
     282         DO ja = 1, iadd 
     283            fbdata%caddname(1+iadd_clm+ja) = padd%cdname(ja) 
     284            fbdata%caddlong(1+iadd_clm+ja,1) = padd%cdlong(ja,1) 
     285            fbdata%caddunit(1+iadd_clm+ja,1) = padd%cdunit(ja,1) 
     286         END DO 
     287      ENDIF 
     288 
    144289      fbdata%caddname(1)   = 'Hx' 
    145       fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 
    146       fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 
    147       fbdata%caddunit(1,1) = 'Degrees centigrade' 
    148       fbdata%caddunit(1,2) = 'PSU' 
    149       fbdata%cgrid(:)      = 'T' 
    150       DO ja = 1, nadd 
    151          fbdata%caddname(1+ja) = padd%cdname(ja) 
    152          DO jvar = 1, 2 
    153             fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 
    154             fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 
    155          END DO 
    156       END DO 
    157           
    158       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
     290      IF ( profdata%lclim ) fbdata%caddname(1+iadd_clm)   = 'CLM' 
     291       
     292      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
    159293 
    160294      IF(lwp) THEN 
    161295         WRITE(numout,*) 
    162          WRITE(numout,*)'obs_wri_p3d :' 
     296         WRITE(numout,*)'obs_wri_prof :' 
    163297         WRITE(numout,*)'~~~~~~~~~~~~~' 
    164          WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname) 
    165       ENDIF 
    166  
    167       ! Transform obs_prof data structure into obfbdata structure 
     298         WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 
     299      ENDIF 
     300 
     301      ! Transform obs_prof data structure into obfb data structure 
    168302      fbdata%cdjuldref = '19500101000000' 
    169303      DO jo = 1, profdata%nprof 
    … …  
    173307         fbdata%ivqc(jo,:)    = profdata%ivqc(jo,:) 
    174308         fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 
    175          IF ( profdata%nqc(jo) > 10 ) THEN 
    176             fbdata%ioqc(jo)    = 4 
     309         IF ( profdata%nqc(jo) > 255 ) THEN 
     310            fbdata%ioqc(jo)    = IBSET(profdata%nqc(jo),2) 
    177311            fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 
    178             fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10 
     312            fbdata%ioqcf(2,jo) = profdata%nqc(jo) 
    179313         ELSE 
    180314            fbdata%ioqc(jo)    = profdata%nqc(jo) 
    … …  
    205339            &           krefdate = 19500101 ) 
    206340         ! Reform the profiles arrays for output 
    207          DO jvar = 1, 2 
     341         DO jvar = 1, profdata%nvar 
    208342            DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 
    209343               ik = profdata%var(jvar)%nvlidx(jk) 
    210                fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk) 
    211344               fbdata%pob(ik,jo,jvar)    = profdata%var(jvar)%vobs(jk) 
    212345               fbdata%pdep(ik,jo)        = profdata%var(jvar)%vdep(jk) 
    213346               fbdata%idqc(ik,jo)        = profdata%var(jvar)%idqc(jk) 
    214347               fbdata%idqcf(:,ik,jo)     = profdata%var(jvar)%idqcf(:,jk) 
    215                IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN 
    216                   fbdata%ivlqc(ik,jo,jvar) = 4 
     348               IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN 
     349                  fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) 
    217350                  fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 
    218                   fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10 
     351                  fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000 0000 1111 1111') 
    219352               ELSE 
    220353                  fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) 
    … …  
    222355               ENDIF 
    223356               fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk) 
    224                DO ja = 1, nadd 
    225                   fbdata%padd(ik,jo,1+ja,jvar) = & 
     357                
     358               fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk) 
     359               IF ( profdata%lclim ) THEN            
     360                  fbdata%padd(ik,jo,1+iadd_clm,jvar) = profdata%var(jvar)%vclm(jk)      
     361               ENDIF               
     362               DO ja = 1, iadd 
     363                  fbdata%padd(ik,jo,1+iadd_clm+ja,jvar) = & 
    226364                     & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 
    227365               END DO 
    228                DO je = 1, next 
     366               DO je = 1, iext 
    229367                  fbdata%pext(ik,jo,1+je) = & 
    230368                     & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 
    231369               END DO 
    232                IF ( jvar == 1 ) THEN 
     370               IF ( ( jvar == 1 ) .AND. & 
     371                  & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 
    233372                  fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 
    234373               ENDIF  
    … …  
    237376      END DO 
    238377 
    239       ! Convert insitu temperature to potential temperature using the model 
    240       ! salinity if no potential temperature 
    241       DO jo = 1, fbdata%nobs 
    242          IF ( fbdata%pphi(jo) < 9999.0 ) THEN 
    243             DO jk = 1, fbdata%nlev 
    244                IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 
    245                   & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
    246                   & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 
    247                   & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 
    248                   zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 
    249                      &              REAL(fbdata%pphi(jo),wp) ) 
    250                   fbdata%pob(jk,jo,1) = potemp( & 
    251                      &                     REAL(fbdata%padd(jk,jo,1,2), wp),  & 
    252                      &                     REAL(fbdata%pext(jk,jo,1), wp), & 
    253                      &                     zpres, 0.0_wp ) 
    254                ENDIF 
    255             END DO 
    256          ENDIF 
    257       END DO 
    258        
     378      IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 
     379         ! Convert insitu temperature to potential temperature using the model 
     380         ! salinity if no potential temperature 
     381         DO jo = 1, fbdata%nobs 
     382            IF ( fbdata%pphi(jo) < 9999.0 ) THEN 
     383               DO jk = 1, fbdata%nlev 
     384                  IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 
     385                     & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
     386                     & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 
     387                     & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 
     388                     zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 
     389                        &              REAL(fbdata%pphi(jo),wp) ) 
     390                     fbdata%pob(jk,jo,1) = potemp( & 
     391                        &                     REAL(fbdata%padd(jk,jo,1,2), wp),  & 
     392                        &                     REAL(fbdata%pext(jk,jo,1), wp), & 
     393                        &                     zpres, 0.0_wp ) 
     394                  ENDIF 
     395               END DO 
     396            ENDIF 
     397         END DO 
     398      ENDIF 
     399 
    259400      ! Write the obfbdata structure 
    260       CALL write_obfbdata( cfname, fbdata ) 
     401      CALL write_obfbdata( clfname, fbdata ) 
    261402 
    262403      ! Output some basic statistics 
    … …  
    264405 
    265406      CALL dealloc_obfbdata( fbdata ) 
    266       
    267    END SUBROUTINE obs_wri_p3d 
    268  
    269    SUBROUTINE obs_wri_sla( cprefix, sladata, padd, pext ) 
     407 
     408   END SUBROUTINE obs_wri_prof 
     409 
     410   SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 
    270411      !!----------------------------------------------------------------------- 
    271412      !! 
    272       !!                     *** ROUTINE obs_wri_sla  *** 
    273       !! 
    274       !! ** Purpose : Write SLA observation diagnostics 
    275       !!              related  
     413      !!                     *** ROUTINE obs_wri_surf  *** 
     414      !! 
     415      !! ** Purpose : Write surface observation files 
    276416      !! 
    277417      !! ** Method  : NetCDF 
    … …  
    281421      !!      ! 07-03  (K. Mogensen) Original 
    282422      !!      ! 09-01  (K. Mogensen) New feedback format. 
     423      !!      ! 15-02  (M. Martin) Combined surface writing routine. 
    283424      !!----------------------------------------------------------------------- 
    284425 
    … …  
    287428 
    288429      !! * Arguments 
    289       CHARACTER(LEN=*), INTENT(IN) :: cprefix          ! Prefix for output files 
    290       TYPE(obs_surf), INTENT(INOUT) :: sladata         ! Full set of SLAa 
     430      TYPE(obs_surf), INTENT(INOUT) :: surfdata         ! Full set of surface data 
    291431      TYPE(obswriinfo), OPTIONAL :: padd               ! Additional info for each variable 
    292432      TYPE(obswriinfo), OPTIONAL :: pext               ! Extra info 
    … …  
    294434      !! * Local declarations 
    295435      TYPE(obfbdata) :: fbdata 
    296       CHARACTER(LEN=40) :: cfname         ! netCDF filename 
    297       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 
     436      CHARACTER(LEN=40) :: clfname         ! netCDF filename 
     437      CHARACTER(LEN=10) :: clfiletype 
     438      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 
     439      CHARACTER(LEN=ilenlong) :: cllongname  ! Long name of variable 
     440      CHARACTER(LEN=ilenunit) :: clunits     ! Units of variable 
     441      CHARACTER(LEN=ilengrid) :: clgrid      ! Grid of variable 
    298442      INTEGER :: jo 
    299443      INTEGER :: ja 
    300444      INTEGER :: je 
    301       INTEGER :: nadd 
    302       INTEGER :: next 
    303  
     445      INTEGER :: iadd 
     446      INTEGER :: iext 
     447      INTEGER :: indx_std 
     448      INTEGER :: iadd_std 
     449      INTEGER :: iadd_clm      
     450      INTEGER :: iadd_mdt  
     451 
     452      IF ( PRESENT( pext ) ) THEN 
     453         iext = pext%inum 
     454      ELSE 
     455         iext = 0 
     456      ENDIF 
     457 
     458 
     459      ! Set up number of additional variables to be ouput: 
     460      ! Hx, CLM, STD, MDT... 
     461  
    304462      IF ( PRESENT( padd ) ) THEN 
    305          nadd = padd%inum 
     463         iadd = padd%inum 
    306464      ELSE 
    307          nadd = 0 
    308       ENDIF 
    309  
    310       IF ( PRESENT( pext ) ) THEN 
    311          next = pext%inum 
    312       ELSE 
    313          next = 0 
    314       ENDIF 
    315  
     465         iadd = 0 
     466      ENDIF 
     467       
     468      iadd_std = 0 
     469      indx_std = -1 
     470      IF ( surfdata%nextra > 0 ) THEN 
     471         DO je = 1, surfdata%nextra 
     472           IF ( TRIM( surfdata%cext(je) ) == 'STD' ) THEN 
     473             iadd_std = 1 
     474             indx_std = je 
     475           ENDIF 
     476         END DO 
     477      ENDIF 
     478       
     479      iadd_clm = 0 
     480      IF ( surfdata%lclim ) iadd_clm = 1 
     481       
     482      iadd_mdt = 0 
     483      IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) iadd_mdt = 1 
     484       
    316485      CALL init_obfbdata( fbdata ) 
    317486 
    318       CALL alloc_obfbdata( fbdata, 1, sladata%nsurf, 1, & 
    319          &                 2 + nadd, 1 + next, .TRUE. ) 
    320  
    321       fbdata%cname(1)      = 'SLA' 
    322       fbdata%coblong(1)    = 'Sea level anomaly' 
    323       fbdata%cobunit(1)    = 'Metres' 
    324       fbdata%cextname(1)   = 'MDT' 
    325       fbdata%cextlong(1)   = 'Mean dynamic topography' 
    326       fbdata%cextunit(1)   = 'Metres' 
    327       DO je = 1, next 
    328          fbdata%cextname(1+je) = pext%cdname(je) 
    329          fbdata%cextlong(1+je) = pext%cdlong(je,1) 
    330          fbdata%cextunit(1+je) = pext%cdunit(je,1) 
    331       END DO 
     487      SELECT CASE ( TRIM(surfdata%cvars(1)) ) 
     488      CASE('SLA') 
     489          
     490         ! SLA needs special treatment because of MDT, so is all done here 
     491         ! Other variables are done more generically 
     492         ! No climatology for SLA, MDT is our best estimate of that and is already output. 
     493 
     494         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     495            &                 1 + iadd_mdt + iadd_std + iadd, & 
     496            &                 1 + iext, .TRUE. ) 
     497 
     498         clfiletype = 'slafb' 
     499         fbdata%cname(1)      = surfdata%cvars(1) 
     500         fbdata%coblong(1)    = 'Sea level anomaly' 
     501         fbdata%cobunit(1)    = 'Metres' 
     502         fbdata%cextname(1)   = 'MDT' 
     503         fbdata%cextlong(1)   = 'Mean dynamic topography' 
     504         fbdata%cextunit(1)   = 'Metres' 
     505         DO je = 1, iext 
     506            fbdata%cextname(je) = pext%cdname(je) 
     507            fbdata%cextlong(je) = pext%cdlong(je,1) 
     508            fbdata%cextunit(je) = pext%cdunit(je,1) 
     509         END DO 
     510         fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 
     511         fbdata%caddunit(1,1) = 'Metres'  
     512         fbdata%caddname(2)   = 'SSH' 
     513         fbdata%caddlong(2,1) = 'Model Sea surface height' 
     514         fbdata%caddunit(2,1) = 'Metres' 
     515         fbdata%cgrid(1)      = 'T' 
     516         DO ja = 1, iadd 
     517            fbdata%caddname(1+iadd_mdt+iadd_std+ja) = padd%cdname(ja) 
     518            fbdata%caddlong(1+iadd_mdt+iadd_std+ja,1) = padd%cdlong(ja,1) 
     519            fbdata%caddunit(1+iadd_mdt+iadd_std+ja,1) = padd%cdunit(ja,1) 
     520         END DO 
     521 
     522      CASE('SST') 
     523 
     524         clfiletype = 'sstfb' 
     525         cllongname = 'Sea surface temperature' 
     526         clunits    = 'Degree centigrade' 
     527         clgrid     = 'T' 
     528          
     529      CASE('ICECONC') 
     530 
     531         clfiletype = 'sicfb' 
     532         cllongname = 'Sea ice' 
     533         clunits    = 'Fraction' 
     534         clgrid     = 'T' 
     535 
     536      CASE('SSS') 
     537 
     538         clfiletype = 'sssfb' 
     539         cllongname = 'Sea surface salinity' 
     540         clunits    = 'psu' 
     541         clgrid     = 'T' 
     542          
     543      CASE('SLCHLTOT') 
     544 
     545         clfiletype = 'slchltotfb' 
     546         cllongname = 'Surface total log10(chlorophyll)' 
     547         clunits    = 'log10(mg/m3)' 
     548         clgrid     = 'T' 
     549 
     550      CASE('SLCHLDIA') 
     551 
     552         clfiletype = 'slchldiafb' 
     553         cllongname = 'Surface diatom log10(chlorophyll)' 
     554         clunits    = 'log10(mg/m3)' 
     555         clgrid     = 'T' 
     556 
     557      CASE('SLCHLNON') 
     558 
     559         clfiletype = 'slchlnonfb' 
     560         cllongname = 'Surface non-diatom log10(chlorophyll)' 
     561         clunits    = 'log10(mg/m3)' 
     562         clgrid     = 'T' 
     563 
     564      CASE('SLCHLDIN') 
     565 
     566         clfiletype = 'slchldinfb' 
     567         cllongname = 'Surface dinoflagellate log10(chlorophyll)' 
     568         clunits    = 'log10(mg/m3)' 
     569         clgrid     = 'T' 
     570 
     571      CASE('SLCHLMIC') 
     572 
     573         clfiletype = 'slchlmicfb' 
     574         cllongname = 'Surface microphytoplankton log10(chlorophyll)' 
     575         clunits    = 'log10(mg/m3)' 
     576         clgrid     = 'T' 
     577 
     578      CASE('SLCHLNAN') 
     579 
     580         clfiletype = 'slchlnanfb' 
     581         cllongname = 'Surface nanophytoplankton log10(chlorophyll)' 
     582         clunits    = 'log10(mg/m3)' 
     583         clgrid     = 'T' 
     584 
     585      CASE('SLCHLPIC') 
     586 
     587         clfiletype = 'slchlpicfb' 
     588         cllongname = 'Surface picophytoplankton log10(chlorophyll)' 
     589         clunits    = 'log10(mg/m3)' 
     590         clgrid     = 'T' 
     591 
     592      CASE('SCHLTOT') 
     593 
     594         clfiletype = 'schltotfb' 
     595         cllongname = 'Surface total chlorophyll' 
     596         clunits    = 'mg/m3' 
     597         clgrid     = 'T' 
     598 
     599      CASE('SLPHYTOT') 
     600 
     601         clfiletype = 'slphytotfb' 
     602         cllongname = 'Surface total log10(phytoplankton carbon)' 
     603         clunits    = 'log10(mmolC/m3)' 
     604         clgrid     = 'T' 
     605 
     606      CASE('SLPHYDIA') 
     607 
     608         clfiletype = 'slphydiafb' 
     609         cllongname = 'Surface diatom log10(phytoplankton carbon)' 
     610         clunits    = 'log10(mmolC/m3)' 
     611         clgrid     = 'T' 
     612 
     613      CASE('SLPHYNON') 
     614 
     615         clfiletype = 'slphynonfb' 
     616         cllongname = 'Surface non-diatom log10(phytoplankton carbon)' 
     617         clunits    = 'log10(mmolC/m3)' 
     618         clgrid     = 'T' 
     619 
     620      CASE('SSPM') 
     621 
     622         clfiletype = 'sspmfb' 
     623         cllongname = 'Surface suspended particulate matter' 
     624         clunits    = 'g/m3' 
     625         clgrid     = 'T' 
     626 
     627      CASE('SKD490') 
     628 
     629         clfiletype = 'skd490fb' 
     630         cllongname = 'Surface attenuation coefficient of downwelling radiation at 490 nm' 
     631         clunits    = 'm-1' 
     632         clgrid     = 'T' 
     633 
     634      CASE('SFCO2') 
     635 
     636         clfiletype = 'sfco2fb' 
     637         cllongname = 'Surface fugacity of carbon dioxide' 
     638         clunits    = 'uatm' 
     639         clgrid     = 'T' 
     640 
     641      CASE('SPCO2') 
     642 
     643         clfiletype = 'spco2fb' 
     644         cllongname = 'Surface partial pressure of carbon dioxide' 
     645         clunits    = 'uatm' 
     646         clgrid     = 'T' 
     647 
     648      CASE DEFAULT 
     649 
     650         CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 
     651 
     652      END SELECT 
     653 
     654      ! SLA needs special treatment because of MDT, so is done above 
     655      ! Remaining variables treated more generically 
     656 
     657      IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 
     658       
     659         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     660            &                 1 + iadd_std + iadd_clm + iadd, iext, .TRUE. ) 
     661 
     662         fbdata%cname(1)      = surfdata%cvars(1) 
     663         fbdata%coblong(1)    = cllongname 
     664         fbdata%cobunit(1)    = clunits 
     665         DO je = 1, iext 
     666            fbdata%cextname(je) = pext%cdname(je) 
     667            fbdata%cextlong(je) = pext%cdlong(je,1) 
     668            fbdata%cextunit(je) = pext%cdunit(je,1) 
     669         END DO 
     670         IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 
     671            fbdata%caddlong(1,1) = 'Model interpolated ICE' 
     672         ELSE 
     673            fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 
     674         ENDIF 
     675         fbdata%caddunit(1,1) = clunits 
     676         fbdata%cgrid(1)      = clgrid 
     677         DO ja = 1, iadd 
     678            fbdata%caddname(1+iadd_mdt+iadd_std+iadd_clm+ja) = padd%cdname(ja) 
     679            fbdata%caddlong(1+iadd_mdt+iadd_std+iadd_clm+ja,1) = padd%cdlong(ja,1) 
     680            fbdata%caddunit(1+iadd_mdt+iadd_std+iadd_clm+ja,1) = padd%cdunit(ja,1) 
     681         END DO 
     682 
     683      ENDIF 
     684       
    332685      fbdata%caddname(1)   = 'Hx' 
    333       fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 
    334       fbdata%caddunit(1,1) = 'Metres'  
    335       fbdata%caddname(2)   = 'SSH' 
    336       fbdata%caddlong(2,1) = 'Model Sea surface height' 
    337       fbdata%caddunit(2,1) = 'Metres' 
    338       fbdata%cgrid(1)      = 'T' 
    339       DO ja = 1, nadd 
    340          fbdata%caddname(2+ja) = padd%cdname(ja) 
    341          fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 
    342          fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 
    343       END DO 
    344  
    345       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
     686      IF ( indx_std /= -1 ) THEN 
     687         fbdata%caddname(1+iadd_mdt+iadd_std)   = surfdata%cext(indx_std) 
     688         fbdata%caddlong(1+iadd_mdt+iadd_std,1) = 'Obs error standard deviation' 
     689         fbdata%caddunit(1+iadd_mdt+iadd_std,1) = fbdata%cobunit(1) 
     690      ENDIF 
     691       
     692      IF ( surfdata%lclim ) THEN 
     693         fbdata%caddname(1+iadd_mdt+iadd_std+iadd_clm)   = 'CLM' 
     694         fbdata%caddlong(1+iadd_mdt+iadd_std+iadd_clm,1) = 'Climatology' 
     695         fbdata%caddunit(1+iadd_mdt+iadd_std+iadd_clm,1) = fbdata%cobunit(1) 
     696      ENDIF 
     697       
     698       
     699      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
    346700 
    347701      IF(lwp) THEN 
    348702         WRITE(numout,*) 
    349          WRITE(numout,*)'obs_wri_sla :' 
     703         WRITE(numout,*)'obs_wri_surf :' 
    350704         WRITE(numout,*)'~~~~~~~~~~~~~' 
    351          WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname) 
    352       ENDIF 
    353  
    354       ! Transform obs_prof data structure into obfbdata structure 
     705         WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 
     706      ENDIF 
     707 
     708      ! Transform surf data structure into obfbdata structure 
    355709      fbdata%cdjuldref = '19500101000000' 
    356       DO jo = 1, sladata%nsurf 
    357          fbdata%plam(jo)      = sladata%rlam(jo) 
    358          fbdata%pphi(jo)      = sladata%rphi(jo) 
    359          WRITE(fbdata%cdtyp(jo),'(I4)') sladata%ntyp(jo) 
     710      DO jo = 1, surfdata%nsurf 
     711         fbdata%plam(jo)      = surfdata%rlam(jo) 
     712         fbdata%pphi(jo)      = surfdata%rphi(jo) 
     713         WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 
    360714         fbdata%ivqc(jo,:)    = 0 
    361715         fbdata%ivqcf(:,jo,:) = 0 
    362          IF ( sladata%nqc(jo) > 10 ) THEN 
     716         IF ( surfdata%nqc(jo) > 255 ) THEN 
    363717            fbdata%ioqc(jo)    = 4 
    364718            fbdata%ioqcf(1,jo) = 0 
    365             fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10 
     719            fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 
    366720         ELSE 
    367             fbdata%ioqc(jo)    = sladata%nqc(jo) 
     721            fbdata%ioqc(jo)    = surfdata%nqc(jo) 
    368722            fbdata%ioqcf(:,jo) = 0 
    369723         ENDIF 
    … …  
    372726         fbdata%itqc(jo)      = 0 
    373727         fbdata%itqcf(:,jo)   = 0 
    374          fbdata%cdwmo(jo)     = sladata%cwmo(jo) 
    375          fbdata%kindex(jo)    = sladata%nsfil(jo) 
     728         fbdata%cdwmo(jo)     = surfdata%cwmo(jo) 
     729         fbdata%kindex(jo)    = surfdata%nsfil(jo) 
    376730         IF (ln_grid_global) THEN 
    377             fbdata%iobsi(jo,1) = sladata%mi(jo) 
    378             fbdata%iobsj(jo,1) = sladata%mj(jo) 
     731            fbdata%iobsi(jo,1) = surfdata%mi(jo) 
     732            fbdata%iobsj(jo,1) = surfdata%mj(jo) 
    379733         ELSE 
    380             fbdata%iobsi(jo,1) = mig(sladata%mi(jo)) 
    381             fbdata%iobsj(jo,1) = mjg(sladata%mj(jo)) 
     734            fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 
     735            fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 
    382736         ENDIF 
    383737         CALL greg2jul( 0, & 
    384             &           sladata%nmin(jo), & 
    385             &           sladata%nhou(jo), & 
    386             &           sladata%nday(jo), & 
    387             &           sladata%nmon(jo), & 
    388             &           sladata%nyea(jo), & 
     738            &           surfdata%nmin(jo), & 
     739            &           surfdata%nhou(jo), & 
     740            &           surfdata%nday(jo), & 
     741            &           surfdata%nmon(jo), & 
     742            &           surfdata%nyea(jo), & 
    389743            &           fbdata%ptim(jo),   & 
    390744            &           krefdate = 19500101 ) 
    391          fbdata%padd(1,jo,1,1) = sladata%rmod(jo,1) 
    392          fbdata%padd(1,jo,2,1) = sladata%rext(jo,1) 
    393          fbdata%pob(1,jo,1)    = sladata%robs(jo,1)  
     745                     
     746         fbdata%pob(1,jo,1)    = surfdata%robs(jo,1)  
    394747         fbdata%pdep(1,jo)     = 0.0 
    395748         fbdata%idqc(1,jo)     = 0 
    396749         fbdata%idqcf(:,1,jo)  = 0 
    397          IF ( sladata%nqc(jo) > 10 ) THEN 
     750         IF ( surfdata%nqc(jo) > 255 ) THEN 
    398751            fbdata%ivqc(jo,1)       = 4 
    399752            fbdata%ivlqc(1,jo,1)    = 4 
    400753            fbdata%ivlqcf(1,1,jo,1) = 0 
    401             fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10 
     754            fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 
    402755         ELSE 
    403             fbdata%ivqc(jo,1)       = sladata%nqc(jo) 
    404             fbdata%ivlqc(1,jo,1)    = sladata%nqc(jo) 
     756            fbdata%ivqc(jo,1)       = surfdata%nqc(jo) 
     757            fbdata%ivlqc(1,jo,1)    = surfdata%nqc(jo) 
    405758            fbdata%ivlqcf(:,1,jo,1) = 0 
    406759         ENDIF 
    407760         fbdata%iobsk(1,jo,1)  = 0 
    408          fbdata%pext(1,jo,1) = sladata%rext(jo,2) 
    409          DO ja = 1, nadd 
    410             fbdata%padd(1,jo,2+ja,1) = & 
    411                & sladata%rext(jo,padd%ipoint(ja)) 
    412          END DO 
    413          DO je = 1, next 
     761  
     762         ! Additional variables. 
     763         ! Hx is always the first additional variable 
     764         fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 
     765         ! MDT is output as an additional variable if SLA obs type 
     766         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) THEN 
     767            fbdata%padd(1,jo,1+iadd_mdt,1) = surfdata%rext(jo,1) 
     768         ENDIF     
     769         ! STD is output as an additional variable if available 
     770         IF ( indx_std /= -1 ) THEN 
     771            fbdata%padd(1,jo,1+iadd_mdt+iadd_std,1) = surfdata%rext(jo,indx_std) 
     772         ENDIF 
     773         ! CLM is output as an additional variable if available 
     774         IF ( surfdata%lclim ) THEN 
     775            fbdata%padd(1,jo,1+iadd_mdt+iadd_std+iadd_clm,1) = surfdata%rclm(jo,1) 
     776         ENDIF 
     777         ! Then other additional variables are output 
     778         DO ja = 1, iadd 
     779            fbdata%padd(1,jo,1+iadd_mdt+iadd_std+iadd_clm+ja,1) = & 
     780               & surfdata%rext(jo,padd%ipoint(ja)) 
     781         END DO 
     782          
     783         ! Extra variables 
     784         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2)          
     785         DO je = 1, iext 
    414786            fbdata%pext(1,jo,1+je) = & 
    415                & sladata%rext(jo,pext%ipoint(je)) 
     787               & surfdata%rext(jo,pext%ipoint(je)) 
    416788         END DO 
    417789      END DO 
    418790 
    419791      ! Write the obfbdata structure 
    420       CALL write_obfbdata( cfname, fbdata ) 
     792      CALL write_obfbdata( clfname, fbdata ) 
    421793 
    422794      ! Output some basic statistics 
    … …  
    425797      CALL dealloc_obfbdata( fbdata ) 
    426798 
    427    END SUBROUTINE obs_wri_sla 
    428  
    429    SUBROUTINE obs_wri_sst( cprefix, sstdata, padd, pext ) 
    430       !!----------------------------------------------------------------------- 
    431       !! 
    432       !!                     *** ROUTINE obs_wri_sst  *** 
    433       !! 
    434       !! ** Purpose : Write SST observation diagnostics 
    435       !!              related  
    436       !! 
    437       !! ** Method  : NetCDF 
    438       !!  
    439       !! ** Action  : 
    440       !! 
    441       !!      ! 07-07  (S. Ricci) Original 
    442       !!      ! 09-01  (K. Mogensen) New feedback format. 
    443       !!----------------------------------------------------------------------- 
    444  
    445       !! * Modules used 
    446       IMPLICIT NONE 
    447  
    448       !! * Arguments 
    449       CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files 
    450       TYPE(obs_surf), INTENT(INOUT) :: sstdata      ! Full set of SST 
    451       TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable 
    452       TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info 
    453  
    454       !! * Local declarations  
    455       TYPE(obfbdata) :: fbdata 
    456       CHARACTER(LEN=40) ::  cfname             ! netCDF filename 
    457       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sst' 
    458       INTEGER :: jo 
    459       INTEGER :: ja 
    460       INTEGER :: je 
    461       INTEGER :: nadd 
    462       INTEGER :: next 
    463  
    464       IF ( PRESENT( padd ) ) THEN 
    465          nadd = padd%inum 
    466       ELSE 
    467          nadd = 0 
    468       ENDIF 
    469  
    470       IF ( PRESENT( pext ) ) THEN 
    471          next = pext%inum 
    472       ELSE 
    473          next = 0 
    474       ENDIF 
    475  
    476       CALL init_obfbdata( fbdata ) 
    477  
    478       CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, & 
    479          &                 1 + nadd, next, .TRUE. ) 
    480  
    481       fbdata%cname(1)      = 'SST' 
    482       fbdata%coblong(1)    = 'Sea surface temperature' 
    483       fbdata%cobunit(1)    = 'Degree centigrade' 
    484       DO je = 1, next 
    485          fbdata%cextname(je) = pext%cdname(je) 
    486          fbdata%cextlong(je) = pext%cdlong(je,1) 
    487          fbdata%cextunit(je) = pext%cdunit(je,1) 
    488       END DO 
    489       fbdata%caddname(1)   = 'Hx' 
    490       fbdata%caddlong(1,1) = 'Model interpolated SST' 
    491       fbdata%caddunit(1,1) = 'Degree centigrade' 
    492       fbdata%cgrid(1)      = 'T' 
    493       DO ja = 1, nadd 
    494          fbdata%caddname(1+ja) = padd%cdname(ja) 
    495          fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
    496          fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    497       END DO 
    498  
    499       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    500  
    501       IF(lwp) THEN 
    502          WRITE(numout,*) 
    503          WRITE(numout,*)'obs_wri_sst :' 
    504          WRITE(numout,*)'~~~~~~~~~~~~~' 
    505          WRITE(numout,*)'Writing SST feedback file : ',TRIM(cfname) 
    506       ENDIF 
    507  
    508       ! Transform obs_prof data structure into obfbdata structure 
    509       fbdata%cdjuldref = '19500101000000' 
    510       DO jo = 1, sstdata%nsurf 
    511          fbdata%plam(jo)      = sstdata%rlam(jo) 
    512          fbdata%pphi(jo)      = sstdata%rphi(jo) 
    513          WRITE(fbdata%cdtyp(jo),'(I4)') sstdata%ntyp(jo) 
    514          fbdata%ivqc(jo,:)    = 0 
    515          fbdata%ivqcf(:,jo,:) = 0 
    516          IF ( sstdata%nqc(jo) > 10 ) THEN 
    517             fbdata%ioqc(jo)    = 4 
    518             fbdata%ioqcf(1,jo) = 0 
    519             fbdata%ioqcf(2,jo) = sstdata%nqc(jo) - 10 
    520          ELSE 
    521             fbdata%ioqc(jo)    = MAX(sstdata%nqc(jo),1) 
    522             fbdata%ioqcf(:,jo) = 0 
    523          ENDIF 
    524          fbdata%ipqc(jo)      = 0 
    525          fbdata%ipqcf(:,jo)   = 0 
    526          fbdata%itqc(jo)      = 0 
    527          fbdata%itqcf(:,jo)   = 0 
    528          fbdata%cdwmo(jo)     = '' 
    529          fbdata%kindex(jo)    = sstdata%nsfil(jo) 
    530          IF (ln_grid_global) THEN 
    531             fbdata%iobsi(jo,1) = sstdata%mi(jo) 
    532             fbdata%iobsj(jo,1) = sstdata%mj(jo) 
    533          ELSE 
    534             fbdata%iobsi(jo,1) = mig(sstdata%mi(jo)) 
    535             fbdata%iobsj(jo,1) = mjg(sstdata%mj(jo)) 
    536          ENDIF 
    537          CALL greg2jul( 0, & 
    538             &           sstdata%nmin(jo), & 
    539             &           sstdata%nhou(jo), & 
    540             &           sstdata%nday(jo), & 
    541             &           sstdata%nmon(jo), & 
    542             &           sstdata%nyea(jo), & 
    543             &           fbdata%ptim(jo),   & 
    544             &           krefdate = 19500101 ) 
    545          fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1) 
    546          fbdata%pob(1,jo,1)    = sstdata%robs(jo,1) 
    547          fbdata%pdep(1,jo)     = 0.0 
    548          fbdata%idqc(1,jo)     = 0 
    549          fbdata%idqcf(:,1,jo)  = 0 
    550          IF ( sstdata%nqc(jo) > 10 ) THEN 
    551             fbdata%ivqc(jo,1)       = 4 
    552             fbdata%ivlqc(1,jo,1)    = 4 
    553             fbdata%ivlqcf(1,1,jo,1) = 0 
    554             fbdata%ivlqcf(2,1,jo,1) = sstdata%nqc(jo) - 10 
    555          ELSE 
    556             fbdata%ivqc(jo,1)       = MAX(sstdata%nqc(jo),1) 
    557             fbdata%ivlqc(1,jo,1)    = MAX(sstdata%nqc(jo),1) 
    558             fbdata%ivlqcf(:,1,jo,1) = 0 
    559          ENDIF 
    560          fbdata%iobsk(1,jo,1)  = 0 
    561          DO ja = 1, nadd 
    562             fbdata%padd(1,jo,1+ja,1) = & 
    563                & sstdata%rext(jo,padd%ipoint(ja)) 
    564          END DO 
    565          DO je = 1, next 
    566             fbdata%pext(1,jo,je) = & 
    567                & sstdata%rext(jo,pext%ipoint(je)) 
    568          END DO 
    569  
    570       END DO 
    571  
    572       ! Write the obfbdata structure 
    573  
    574       CALL write_obfbdata( cfname, fbdata ) 
    575  
    576       ! Output some basic statistics 
    577       CALL obs_wri_stats( fbdata ) 
    578  
    579       CALL dealloc_obfbdata( fbdata ) 
    580  
    581    END SUBROUTINE obs_wri_sst 
    582  
    583    SUBROUTINE obs_wri_sss 
    584    END SUBROUTINE obs_wri_sss 
    585  
    586    SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext ) 
    587       !!----------------------------------------------------------------------- 
    588       !! 
    589       !!                     *** ROUTINE obs_wri_seaice  *** 
    590       !! 
    591       !! ** Purpose : Write sea ice observation diagnostics 
    592       !!              related  
    593       !! 
    594       !! ** Method  : NetCDF 
    595       !!  
    596       !! ** Action  : 
    597       !! 
    598       !!      ! 07-07  (S. Ricci) Original 
    599       !!      ! 09-01  (K. Mogensen) New feedback format. 
    600       !!----------------------------------------------------------------------- 
    601  
    602       !! * Modules used 
    603       IMPLICIT NONE 
    604  
    605       !! * Arguments 
    606       CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files 
    607       TYPE(obs_surf), INTENT(INOUT) :: seaicedata   ! Full set of sea ice 
    608       TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable 
    609       TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info 
    610  
    611       !! * Local declarations  
    612       TYPE(obfbdata) :: fbdata 
    613       CHARACTER(LEN=40) :: cfname             ! netCDF filename 
    614       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_seaice' 
    615       INTEGER :: jo 
    616       INTEGER :: ja 
    617       INTEGER :: je 
    618       INTEGER :: nadd 
    619       INTEGER :: next 
    620  
    621       IF ( PRESENT( padd ) ) THEN 
    622          nadd = padd%inum 
    623       ELSE 
    624          nadd = 0 
    625       ENDIF 
    626  
    627       IF ( PRESENT( pext ) ) THEN 
    628          next = pext%inum 
    629       ELSE 
    630          next = 0 
    631       ENDIF 
    632  
    633       CALL init_obfbdata( fbdata ) 
    634  
    635       CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. ) 
    636  
    637       fbdata%cname(1)      = 'SEAICE' 
    638       fbdata%coblong(1)    = 'Sea ice' 
    639       fbdata%cobunit(1)    = 'Fraction' 
    640       DO je = 1, next 
    641          fbdata%cextname(je) = pext%cdname(je) 
    642          fbdata%cextlong(je) = pext%cdlong(je,1) 
    643          fbdata%cextunit(je) = pext%cdunit(je,1) 
    644       END DO 
    645       fbdata%caddname(1)   = 'Hx' 
    646       fbdata%caddlong(1,1) = 'Model interpolated ICE' 
    647       fbdata%caddunit(1,1) = 'Fraction' 
    648       fbdata%cgrid(1)      = 'T' 
    649       DO ja = 1, nadd 
    650          fbdata%caddname(1+ja) = padd%cdname(ja) 
    651          fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
    652          fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    653       END DO 
    654  
    655       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    656  
    657       IF(lwp) THEN 
    658          WRITE(numout,*) 
    659          WRITE(numout,*)'obs_wri_seaice :' 
    660          WRITE(numout,*)'~~~~~~~~~~~~~~~~' 
    661          WRITE(numout,*)'Writing SEAICE feedback file : ',TRIM(cfname) 
    662       ENDIF 
    663  
    664       ! Transform obs_prof data structure into obfbdata structure 
    665       fbdata%cdjuldref = '19500101000000' 
    666       DO jo = 1, seaicedata%nsurf 
    667          fbdata%plam(jo)      = seaicedata%rlam(jo) 
    668          fbdata%pphi(jo)      = seaicedata%rphi(jo) 
    669          WRITE(fbdata%cdtyp(jo),'(I4)') seaicedata%ntyp(jo) 
    670          fbdata%ivqc(jo,:)    = 0 
    671          fbdata%ivqcf(:,jo,:) = 0 
    672          IF ( seaicedata%nqc(jo) > 10 ) THEN 
    673             fbdata%ioqc(jo)    = 4 
    674             fbdata%ioqcf(1,jo) = 0 
    675             fbdata%ioqcf(2,jo) = seaicedata%nqc(jo) - 10 
    676          ELSE 
    677             fbdata%ioqc(jo)    = MAX(seaicedata%nqc(jo),1) 
    678             fbdata%ioqcf(:,jo) = 0 
    679          ENDIF 
    680          fbdata%ipqc(jo)      = 0 
    681          fbdata%ipqcf(:,jo)   = 0 
    682          fbdata%itqc(jo)      = 0 
    683          fbdata%itqcf(:,jo)   = 0 
    684          fbdata%cdwmo(jo)     = '' 
    685          fbdata%kindex(jo)    = seaicedata%nsfil(jo) 
    686          IF (ln_grid_global) THEN 
    687             fbdata%iobsi(jo,1) = seaicedata%mi(jo) 
    688             fbdata%iobsj(jo,1) = seaicedata%mj(jo) 
    689          ELSE 
    690             fbdata%iobsi(jo,1) = mig(seaicedata%mi(jo)) 
    691             fbdata%iobsj(jo,1) = mjg(seaicedata%mj(jo)) 
    692          ENDIF 
    693          CALL greg2jul( 0, & 
    694             &           seaicedata%nmin(jo), & 
    695             &           seaicedata%nhou(jo), & 
    696             &           seaicedata%nday(jo), & 
    697             &           seaicedata%nmon(jo), & 
    698             &           seaicedata%nyea(jo), & 
    699             &           fbdata%ptim(jo),   & 
    700             &           krefdate = 19500101 ) 
    701          fbdata%padd(1,jo,1,1) = seaicedata%rmod(jo,1) 
    702          fbdata%pob(1,jo,1)    = seaicedata%robs(jo,1) 
    703          fbdata%pdep(1,jo)     = 0.0 
    704          fbdata%idqc(1,jo)     = 0 
    705          fbdata%idqcf(:,1,jo)  = 0 
    706          IF ( seaicedata%nqc(jo) > 10 ) THEN 
    707             fbdata%ivlqc(1,jo,1) = 4 
    708             fbdata%ivlqcf(1,1,jo,1) = 0 
    709             fbdata%ivlqcf(2,1,jo,1) = seaicedata%nqc(jo) - 10 
    710          ELSE 
    711             fbdata%ivlqc(1,jo,1) = MAX(seaicedata%nqc(jo),1) 
    712             fbdata%ivlqcf(:,1,jo,1) = 0 
    713          ENDIF 
    714          fbdata%iobsk(1,jo,1)  = 0 
    715          DO ja = 1, nadd 
    716             fbdata%padd(1,jo,1+ja,1) = & 
    717                & seaicedata%rext(jo,padd%ipoint(ja)) 
    718          END DO 
    719          DO je = 1, next 
    720             fbdata%pext(1,jo,je) = & 
    721                & seaicedata%rext(jo,pext%ipoint(je)) 
    722          END DO 
    723  
    724       END DO 
    725  
    726       ! Write the obfbdata structure 
    727       CALL write_obfbdata( cfname, fbdata ) 
    728  
    729       ! Output some basic statistics 
    730       CALL obs_wri_stats( fbdata ) 
    731  
    732       CALL dealloc_obfbdata( fbdata ) 
    733  
    734    END SUBROUTINE obs_wri_seaice 
    735  
    736    SUBROUTINE obs_wri_vel( cprefix, profdata, k2dint, padd, pext ) 
    737       !!----------------------------------------------------------------------- 
    738       !! 
    739       !!                     *** ROUTINE obs_wri_vel  *** 
    740       !! 
    741       !! ** Purpose : Write current (profile) observation  
    742       !!              related diagnostics 
    743       !! 
    744       !! ** Method  : NetCDF 
    745       !!  
    746       !! ** Action  : 
    747       !! 
    748       !! History : 
    749       !!      ! 09-01  (K. Mogensen) New feedback format routine 
    750       !!----------------------------------------------------------------------- 
    751  
    752       !! * Modules used 
    753  
    754       !! * Arguments 
    755       CHARACTER(LEN=*), INTENT(IN) :: cprefix       ! Prefix for output files 
    756       TYPE(obs_prof), INTENT(INOUT) :: profdata     ! Full set of profile data 
    757       INTEGER, INTENT(IN) :: k2dint                 ! Horizontal interpolation method 
    758       TYPE(obswriinfo), OPTIONAL :: padd            ! Additional info for each variable 
    759       TYPE(obswriinfo), OPTIONAL :: pext            ! Extra info 
    760  
    761       !! * Local declarations 
    762       TYPE(obfbdata) :: fbdata 
    763       CHARACTER(LEN=40) :: cfname 
    764       INTEGER :: ilevel 
    765       INTEGER :: jvar 
    766       INTEGER :: jk 
    767       INTEGER :: ik 
    768       INTEGER :: jo 
    769       INTEGER :: ja 
    770       INTEGER :: je 
    771       INTEGER :: nadd 
    772       INTEGER :: next 
    773       REAL(wp) :: zpres 
    774       REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    775          & zu, & 
    776          & zv 
    777  
    778       IF ( PRESENT( padd ) ) THEN 
    779          nadd = padd%inum 
    780       ELSE 
    781          nadd = 0 
    782       ENDIF 
    783  
    784       IF ( PRESENT( pext ) ) THEN 
    785          next = pext%inum 
    786       ELSE 
    787          next = 0 
    788       ENDIF 
    789  
    790       CALL init_obfbdata( fbdata ) 
    791  
    792       ! Find maximum level 
    793       ilevel = 0 
    794       DO jvar = 1, 2 
    795          ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 
    796       END DO 
    797       CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 2, 0, .TRUE. ) 
    798  
    799       fbdata%cname(1)      = 'UVEL' 
    800       fbdata%cname(2)      = 'VVEL' 
    801       fbdata%coblong(1)    = 'Zonal velocity' 
    802       fbdata%coblong(2)    = 'Meridional velocity' 
    803       fbdata%cobunit(1)    = 'm/s' 
    804       fbdata%cobunit(2)    = 'm/s' 
    805       DO je = 1, next 
    806          fbdata%cextname(je) = pext%cdname(je) 
    807          fbdata%cextlong(je) = pext%cdlong(je,1) 
    808          fbdata%cextunit(je) = pext%cdunit(je,1) 
    809       END DO 
    810       fbdata%caddname(1)   = 'Hx' 
    811       fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 
    812       fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 
    813       fbdata%caddunit(1,1) = 'm/s' 
    814       fbdata%caddunit(1,2) = 'm/s' 
    815       fbdata%caddname(2)   = 'HxG' 
    816       fbdata%caddlong(2,1) = 'Model interpolated zonal velocity (model grid)' 
    817       fbdata%caddlong(2,2) = 'Model interpolated meridional velocity (model grid)' 
    818       fbdata%caddunit(2,1) = 'm/s' 
    819       fbdata%caddunit(2,2) = 'm/s'  
    820       fbdata%cgrid(1)      = 'U'  
    821       fbdata%cgrid(2)      = 'V' 
    822       DO ja = 1, nadd 
    823          fbdata%caddname(2+ja) = padd%cdname(ja) 
    824          fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 
    825          fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 
    826       END DO 
    827  
    828       WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    829  
    830       IF(lwp) THEN 
    831          WRITE(numout,*) 
    832          WRITE(numout,*)'obs_wri_vel :' 
    833          WRITE(numout,*)'~~~~~~~~~~~~~' 
    834          WRITE(numout,*)'Writing velocuty feedback file : ',TRIM(cfname) 
    835       ENDIF 
    836  
    837       ALLOCATE( & 
    838          & zu(profdata%nvprot(1)), & 
    839          & zv(profdata%nvprot(2))  & 
    840          & ) 
    841       CALL obs_rotvel( profdata, k2dint, zu, zv ) 
    842  
    843       ! Transform obs_prof data structure into obfbdata structure 
    844       fbdata%cdjuldref = '19500101000000' 
    845       DO jo = 1, profdata%nprof 
    846          fbdata%plam(jo)      = profdata%rlam(jo) 
    847          fbdata%pphi(jo)      = profdata%rphi(jo) 
    848          WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) 
    849          fbdata%ivqc(jo,:)    = profdata%ivqc(jo,:) 
    850          fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 
    851          IF ( profdata%nqc(jo) > 10 ) THEN 
    852             fbdata%ioqc(jo)    = 4 
    853             fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 
    854             fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10 
    855          ELSE 
    856             fbdata%ioqc(jo)    = profdata%nqc(jo) 
    857             fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) 
    858          ENDIF 
    859          fbdata%ipqc(jo)      = profdata%ipqc(jo) 
    860          fbdata%ipqcf(:,jo)   = profdata%ipqcf(:,jo) 
    861          fbdata%itqc(jo)      = profdata%itqc(jo) 
    862          fbdata%itqcf(:,jo)   = profdata%itqcf(:,jo) 
    863          fbdata%cdwmo(jo)     = profdata%cwmo(jo) 
    864          fbdata%kindex(jo)    = profdata%npfil(jo) 
    865          DO jvar = 1, profdata%nvar 
    866             IF (ln_grid_global) THEN 
    867                fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) 
    868                fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) 
    869             ELSE 
    870                fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) 
    871                fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) 
    872             ENDIF 
    873          END DO 
    874          CALL greg2jul( 0, & 
    875             &           profdata%nmin(jo), & 
    876             &           profdata%nhou(jo), & 
    877             &           profdata%nday(jo), & 
    878             &           profdata%nmon(jo), & 
    879             &           profdata%nyea(jo), & 
    880             &           fbdata%ptim(jo),   & 
    881             &           krefdate = 19500101 ) 
    882          ! Reform the profiles arrays for output 
    883          DO jvar = 1, 2 
    884             DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 
    885                ik = profdata%var(jvar)%nvlidx(jk) 
    886                IF ( jvar == 1 ) THEN 
    887                   fbdata%padd(ik,jo,1,jvar) = zu(jk) 
    888                ELSE 
    889                   fbdata%padd(ik,jo,1,jvar) = zv(jk) 
    890                ENDIF 
    891                fbdata%padd(ik,jo,2,jvar) = profdata%var(jvar)%vmod(jk) 
    892                fbdata%pob(ik,jo,jvar)    = profdata%var(jvar)%vobs(jk) 
    893                fbdata%pdep(ik,jo)        = profdata%var(jvar)%vdep(jk) 
    894                fbdata%idqc(ik,jo)        = profdata%var(jvar)%idqc(jk) 
    895                fbdata%idqcf(:,ik,jo)     = profdata%var(jvar)%idqcf(:,jk) 
    896                IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN 
    897                   fbdata%ivlqc(ik,jo,jvar) = 4 
    898                   fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 
    899                   fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10 
    900                ELSE 
    901                   fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) 
    902                   fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) 
    903                ENDIF 
    904                fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk) 
    905                DO ja = 1, nadd 
    906                   fbdata%padd(ik,jo,2+ja,jvar) = & 
    907                      & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 
    908                END DO 
    909                DO je = 1, next 
    910                   fbdata%pext(ik,jo,je) = & 
    911                      & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 
    912                END DO 
    913             END DO 
    914          END DO 
    915       END DO 
    916  
    917       ! Write the obfbdata structure 
    918       CALL write_obfbdata( cfname, fbdata ) 
    919        
    920       ! Output some basic statistics 
    921       CALL obs_wri_stats( fbdata ) 
    922  
    923       CALL dealloc_obfbdata( fbdata ) 
    924       
    925       DEALLOCATE( & 
    926          & zu, & 
    927          & zv  & 
    928          & ) 
    929  
    930    END SUBROUTINE obs_wri_vel 
     799   END SUBROUTINE obs_wri_surf 
    931800 
    932801   SUBROUTINE obs_wri_stats( fbdata ) 
    … …  
    951820      INTEGER :: jo 
    952821      INTEGER :: jk 
    953  
    954 !      INTEGER :: nlev 
    955 !      INTEGER :: nlevmpp 
    956 !      INTEGER :: nobsmpp 
    957       INTEGER :: numgoodobs 
    958       INTEGER :: numgoodobsmpp 
     822      INTEGER :: inumgoodobs 
     823      INTEGER :: inumgoodobsmpp 
    959824      REAL(wp) :: zsumx 
    960825      REAL(wp) :: zsumx2 
    961826      REAL(wp) :: zomb 
     827       
    962828 
    963829      IF (lwp) THEN 
    964830         WRITE(numout,*) '' 
    965831         WRITE(numout,*) 'obs_wri_stats :' 
    966          WRITE(numout,*) '~~~~~~~~~~~~~~~'  
     832         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    967833      ENDIF 
    968834 
    … …  
    970836         zsumx=0.0_wp 
    971837         zsumx2=0.0_wp 
    972          numgoodobs=0 
     838         inumgoodobs=0 
    973839         DO jo = 1, fbdata%nobs 
    974840            DO jk = 1, fbdata%nlev 
    … …  
    976842                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
    977843                  & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 
    978         
    979              zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 
     844 
     845                  zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 
    980846                  zsumx=zsumx+zomb 
    981847                  zsumx2=zsumx2+zomb**2 
    982                   numgoodobs=numgoodobs+1 
    983           ENDIF 
     848                  inumgoodobs=inumgoodobs+1 
     849               ENDIF 
    984850            ENDDO 
    985851         ENDDO 
    986852 
    987          CALL obs_mpp_sum_integer( numgoodobs, numgoodobsmpp ) 
     853         CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 
    988854         CALL mpp_sum(zsumx) 
    989855         CALL mpp_sum(zsumx2) 
    990856 
    991857         IF (lwp) THEN 
    992        WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',numgoodobsmpp  
    993        WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/numgoodobsmpp 
    994             WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/numgoodobsmpp ) 
    995        WRITE(numout,*) '' 
     858            WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',inumgoodobsmpp  
     859            WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 
     860            WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 
     861            WRITE(numout,*) '' 
    996862         ENDIF 
    997   
     863 
    998864      ENDDO 
    999865 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obsinter_h2d.h90

    r8058 r15670  
    12401240         & zdum,  & 
    12411241         & zaamax 
    1242         
     1242       
     1243      imax = -1  
    12431244      ! Main computation 
    12441245      pflt = 1.0_wp 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/OBS/obsinter_z1d.h90

    r8058 r15670  
    6262         z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep)      ) 
    6363         z1dp = ( pobsdep(jdep)    - pdep(kkco(jdep)-1) ) 
    64          IF ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp 
    65  
    66          zsum = z1dm + z1dp 
     64 
    6765          
    68          IF ( k1dint == 0 ) THEN 
    69  
    70             !----------------------------------------------------------------- 
    71             !  Linear interpolation 
    72             !----------------------------------------------------------------- 
    73             pobs(jdep) = (   z1dm * pobsk(kkco(jdep)-1) & 
    74                &           + z1dp * pobsk(kkco(jdep)  ) ) / zsum 
    75  
    76          ELSEIF ( k1dint == 1 ) THEN 
    77  
    78             !----------------------------------------------------------------- 
    79             ! Cubic spline interpolation 
    80             !----------------------------------------------------------------- 
    81             zsum2 = zsum * zsum 
    82             pobs(jdep)  = (  z1dm                             * pobsk (kkco(jdep)-1) & 
    83                &           + z1dp                             * pobsk (kkco(jdep)  ) & 
    84                &           + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & 
    85                &           +   z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep)  ) & 
    86                &             ) / 6.0_wp                                              & 
    87                &          ) / zsum 
    88  
     66         ! Where both levels are masked, return a fill value 
     67         IF ( ( pobsmask(kkco(jdep)-1) == 0.0_wp ) .AND. (pobsmask(kkco(jdep)) == 0.0_wp) ) THEN 
     68            pobs(jdep)  = 99999. 
     69         ELSE 
     70          
     71            ! Where upper level is masked (e.g., under ice cavity), only use deeper level 
     72            ! otherwise where ob is at or above upper level model T-point,  
     73            ! use upper model level rather than extrapolate 
     74            IF ( pobsmask(kkco(jdep)-1) == 0.0_wp ) THEN 
     75               z1dm = 0.0_wp 
     76            ELSE IF ( pobsdep(jdep) <= pdep(kkco(jdep)-1) ) THEN 
     77               z1dp = 0.0_wp    
     78            END IF    
     79 
     80            ! Where deeper level is masked (e.g., near sea bed), only use upper level 
     81            ! otherwise where ob is at or below deeper level model T-point,  
     82            ! use deeper model level rather than extrapolate 
     83            IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN 
     84               z1dp = 0.0_wp 
     85            ELSE IF ( pobsdep(jdep) >= pdep(kkco(jdep)) ) THEN 
     86               z1dm = 0.0_wp    
     87            END IF    
     88 
     89            zsum = z1dm + z1dp 
     90          
     91            IF ( k1dint == 0 ) THEN 
     92 
     93               !----------------------------------------------------------------- 
     94               !  Linear interpolation 
     95               !----------------------------------------------------------------- 
     96               pobs(jdep) = (   z1dm * pobsk(kkco(jdep)-1) & 
     97                  &           + z1dp * pobsk(kkco(jdep)  ) ) / zsum 
     98 
     99            ELSEIF ( k1dint == 1 ) THEN 
     100 
     101               !----------------------------------------------------------------- 
     102               ! Cubic spline interpolation 
     103               !----------------------------------------------------------------- 
     104               zsum2 = zsum * zsum 
     105               pobs(jdep)  = (  z1dm                             * pobsk (kkco(jdep)-1) & 
     106                  &           + z1dp                             * pobsk (kkco(jdep)  ) & 
     107                  &           + ( z1dm * ( z1dm * z1dm - zsum2 ) * pobs2k(kkco(jdep)-1) & 
     108                  &           +   z1dp * ( z1dp * z1dp - zsum2 ) * pobs2k(kkco(jdep)  ) & 
     109                  &             ) / 6.0_wp                                              & 
     110                  &          ) / zsum 
     111 
     112            ENDIF 
    89113         ENDIF 
    90114      END DO 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r8058 r15670  
    5555   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ttrdmp   !: damping temperature trend (Celcius/s) 
    5656   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   resto    !: restoring coeff. on T and S (s-1) 
    57  
     57   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tclim    !: temperature climatology on each time step(Celcius) 
     58   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sclim    !: salinity climatology on each time step (psu) 
     59    
    5860   !! * Substitutions 
    5961#  include "domzgr_substitute.h90" 
    … …  
    7072      !!                ***  FUNCTION tra_dmp_alloc  *** 
    7173      !!---------------------------------------------------------------------- 
    72       ALLOCATE( strdmp(jpi,jpj,jpk) , ttrdmp(jpi,jpj,jpk), resto(jpi,jpj,jpk), STAT= tra_dmp_alloc ) 
     74      ALLOCATE( strdmp(jpi,jpj,jpk) , ttrdmp(jpi,jpj,jpk), resto(jpi,jpj,jpk), & 
     75         &      tclim(jpi,jpj,jpk) , sclim(jpi,jpj,jpk), STAT= tra_dmp_alloc ) 
    7376      ! 
    7477      IF( lk_mpp            )   CALL mpp_sum ( tra_dmp_alloc ) 
    … …  
    110113      !                           !==   input T-S data at kt   ==! 
    111114      CALL dta_tsd( kt, zts_dta )            ! read and interpolates T-S data at kt 
     115       
     116      tclim(:,:,:) = zts_dta(:,:,:,jp_tem) 
     117      sclim(:,:,:) = zts_dta(:,:,:,jp_sal) 
    112118      ! 
    113119      SELECT CASE ( nn_zdmp )     !==    type of damping   ==! 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r9178 r15670  
    284284 
    285285#if defined key_asminc 
    286 ! WARNING: THIS MAY WELL NOT BE REQUIRED - WE DON'T WANT TO CHANGE T&S BUT THIS MAY COMPENSATE ANOTHER TERM... 
    287 ! Rate of change in e3t for each level is ssh_iau*e3t_0/ht_0 
    288 ! Contribution to tsa should be rate of change in level / per m of ocean? (hence the division by fse3t_n) 
    289       IF( ln_sshinc ) THEN         ! input of heat and salt due to assimilation 
     286      IF( ln_sshinc .and. ln_ssh_hs_cons ) THEN         ! conserve heat and salt when assimilating SSH 
    290287         DO jj = 2, jpj  
    291288            DO ji = fs_2, fs_jpim1 
    … …  
    293290               DO jk = 1, jpkm1 
    294291                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
    295                                         &            + tsn(ji,jj,jk,jp_tem) * zdep * ( e3t_0(ji,jj,jk) / fse3t_n(ji,jj,jk) ) 
     292                                        &            + tsn(ji,jj,jk,jp_tem) * zdep * ( e3t_0(ji,jj,jk) / fse3t_n(ji,jj,jk) )* tmask(ji,jj,jk)  
    296293                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
    297                                         &            + tsn(ji,jj,jk,jp_sal) * zdep * ( e3t_0(ji,jj,jk) / fse3t_n(ji,jj,jk) ) 
     294                                        &            + tsn(ji,jj,jk,jp_sal) * zdep * ( e3t_0(ji,jj,jk) / fse3t_n(ji,jj,jk) )* tmask(ji,jj,jk)  
    298295               END DO 
    299296            END DO   
    … …  
    301298      ENDIF 
    302299#endif 
    303   
     300 
    304301      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
    305302         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 

  • branches/UKMO/AMM15_v3_6_STABLE_package_collate_amm7ps45/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r9538 r15670  
    578578                     hmld_zint_25h(:,:,jn) = hmld_zint_25h(:,:,jn) + hmld_zint(:,:) 
    579579                  ENDIF 
     580                  IF (lwp) THEN 
     581                     IF ( jn .EQ. 1 ) WRITE(numout,*) 'PS :: i_cnt_25h,kt :: ',i_cnt_25h,kt 
     582                  ENDIF 
    580583                  IF( i_cnt_25h .EQ. 25 .AND.  MOD( kt, i_steps*24) == 0 .AND. kt .NE. nn_it000 ) THEN 
     584                     IF (lwp) THEN 
     585                        WRITE(numout,*) 'zdf_mxl_zint (25h) : Outputting 25h data at i_cnt_25h=',i_cnt_25h 
     586                     ENDIF 
    581587                     CALL iom_put( "mldzint25h_"//cmld , hmld_zint_25h(:,:,jn) / 25._wp   ) 
     588                     ! Reset array 
     589                     hmld_zint_25h(:,:,jn) = hmld_zint(:,:) 
     590                     ! Reset 25h counter on last mld_diag 
     591                     IF ( jn .EQ. nn_mld_diag ) i_cnt_25h = 1 
    582592                  ENDIF 
    583593               ENDIF 
    … …  
    590600               IF (lwp) THEN 
    591601                  WRITE(numout,*) 'zdf_mxl_zint (25h) : Summed the following number of hourly values so far',i_cnt_25h 
    592           ENDIF 
     602               ENDIF 
    593603               i_cnt_25h = i_cnt_25h + 1 
    594604               IF( mld_25h_init ) mld_25h_init = .FALSE. 
    595             ENDIF 
    596             IF( i_cnt_25h .EQ. 25 .AND.  MOD( kt, i_steps*24) == 0 .AND. kt .NE. nn_it000 ) THEN 
    597                i_cnt_25h = 1  
    598                DO jn = 1, nn_mld_diag  
    599                      hmld_zint_25h(:,:,jn) = hmld_zint(:,:)  
    600                ENDDO  
    601605            ENDIF 
    602606         ENDIF 
Note: See TracChangeset for help on using the changeset viewer.