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

Changeset 6069


Ignore:
Timestamp:
2015-12-16T16:44:35+01:00 (8 years ago)
Author:
timgraham
Message:

Merge of dev_MetOffice_merge_2015 into branch (only NEMO directory for now).

Location:
branches/2015/dev_merge_2015/NEMOGCM/NEMO
Files:
20 deleted
70 edited
11 copied

Legend:

Unmodified
Added
Removed

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OFF_SRC/domrea.F90

    r6060 r6069  
    113113      INTEGER  ::   ios   ! Local integer output status for namelist read 
    114114      ! 
    115       NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               & 
    116          &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
    117          &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
    118          &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
    119       NAMELIST/namdom/ nn_bathy , rn_bathy, rn_e3zps_min, rn_e3zps_rat, nn_msh    , rn_hmin,   & 
     115      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,                         & 
     116         &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,             & 
     117         &             nn_it000, nn_itend  , nn_date0    , nn_time0, nn_leapy     , nn_istate , nn_stock ,   & 
     118         &             nn_write, ln_iscpl, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
     119      NAMELIST/namdom/ nn_bathy , rn_bathy, rn_e3zps_min, rn_e3zps_rat, nn_msh    , rn_hmin, rn_isfhmin,  & 
    120120         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,            & 
    121121         &             rn_rdtmax, rn_rdth     , nn_baro     , nn_closea , ln_crs, & 
    … …  
    803803      DO jj = 1, jpjm1 
    804804         DO ji = 1, fs_jpim1   ! vector loop 
    805             umask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
    806             vmask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
     805            ssumask(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
     806            ssvmask(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
    807807         END DO 
    808808         DO ji = 1, jpim1      ! NO vector opt. 
    809             fmask_i(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
     809            ssfmask(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
    810810               &            * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 
    811811         END DO 
    812812      END DO 
    813       CALL lbc_lnk( umask_i, 'U', 1._wp )      ! Lateral boundary conditions 
    814       CALL lbc_lnk( vmask_i, 'V', 1._wp ) 
    815       CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
     813      CALL lbc_lnk( ssumask, 'U', 1._wp )      ! Lateral boundary conditions 
     814      CALL lbc_lnk( ssvmask, 'V', 1._wp ) 
     815      CALL lbc_lnk( ssfmask, 'F', 1._wp ) 
    816816 
    817817      ! 3. Ocean/land mask at wu-, wv- and w points  

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r6060 r6069  
    488488         CALL bn2    ( pts, rab_n, rn2  ) ! now    Brunt-Vaisala 
    489489 
    490          ! Partial steps: before Horizontal DErivative 
    491          IF( ln_zps  .AND. .NOT. ln_isfcav)                            & 
    492             &            CALL zps_hde    ( kt, jpts, pts, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient 
    493             &                                        rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
    494          IF( ln_zps .AND.        ln_isfcav)                            & 
    495             &            CALL zps_hde_isf( kt, jpts, pts, gtsu, gtsv,  &    ! Partial steps for top cell (ISF) 
    496             &                                        rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
    497             &                                 gtui, gtvi, grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the first ocean level 
     490      ! Partial steps: before Horizontal DErivative 
     491      IF( ln_zps  .AND. .NOT. ln_isfcav)                            & 
     492         &            CALL zps_hde    ( kt, jpts, pts, gtsu, gtsv,  &  ! Partial steps: before horizontal gradient 
     493         &                                        rhd, gru , grv    )  ! of t, s, rd at the last ocean level 
     494      IF( ln_zps .AND.        ln_isfcav)                            & 
     495         &            CALL zps_hde_isf( kt, jpts, pts, gtsu, gtsv, gtui, gtvi,  &  ! Partial steps for top cell (ISF) 
     496         &                                        rhd, gru , grv , grui, grvi   )  ! of t, s, rd at the first ocean level 
    498497 
    499498         rn2b(:,:,:) = rn2(:,:,:)         ! need for zdfmxl 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

    r5836 r6069  
    148148      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   & 
    149149         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   & 
    150          &             nn_bench, nn_timing 
     150         &             nn_bench, nn_timing, nn_diacfl 
    151151      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    152152         &             jpizoom, jpjzoom, jperio, ln_use_jattr 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r6060 r6069  
    1111   !!             -   ! 2010-05  (D. Lea)  add calc_month_len routine based on day_init  
    1212   !!            3.4  ! 2012-10  (A. Weaver and K. Mogensen) Fix for direct initialization 
     13   !!                 ! 2014-09  (D. Lea)  Local calc_date removed use routine from OBS 
     14   !!                 ! 2015-11  (D. Lea)  Handle non-zero initial time of day 
    1315   !!---------------------------------------------------------------------- 
    1416 
    1517   !!---------------------------------------------------------------------- 
    1618   !!   asm_inc_init   : Initialize the increment arrays and IAU weights 
    17    !!   calc_date      : Compute the calendar date YYYYMMDD on a given step 
    1819   !!   tra_asm_inc    : Apply the tracer (T and S) increments 
    1920   !!   dyn_asm_inc    : Apply the dynamic (u and v) increments 
    … …  
    3839#endif 
    3940   USE sbc_oce          ! Surface boundary condition variables. 
     41   USE diaobs, ONLY: calc_date     ! Compute the calendar date on a given step 
    4042 
    4143   IMPLICIT NONE 
    … …  
    4345    
    4446   PUBLIC   asm_inc_init   !: Initialize the increment arrays and IAU weights 
    45    PUBLIC   calc_date      !: Compute the calendar date YYYYMMDD on a given step 
    4647   PUBLIC   tra_asm_inc    !: Apply the tracer (T and S) increments 
    4748   PUBLIC   dyn_asm_inc    !: Apply the dynamic (u and v) increments 
    … …  
    110111      INTEGER :: iiauper         ! Number of time steps in the IAU period 
    111112      INTEGER :: icycper         ! Number of time steps in the cycle 
    112       INTEGER :: iitend_date     ! Date YYYYMMDD of final time step 
    113       INTEGER :: iitbkg_date     ! Date YYYYMMDD of background time step for Jb term 
    114       INTEGER :: iitdin_date     ! Date YYYYMMDD of background time step for DI 
    115       INTEGER :: iitiaustr_date  ! Date YYYYMMDD of IAU interval start time step 
    116       INTEGER :: iitiaufin_date  ! Date YYYYMMDD of IAU interval final time step 
    117       ! 
     113      REAL(KIND=dp) :: ditend_date     ! Date YYYYMMDD.HHMMSS of final time step 
     114      REAL(KIND=dp) :: ditbkg_date     ! Date YYYYMMDD.HHMMSS of background time step for Jb term 
     115      REAL(KIND=dp) :: ditdin_date     ! Date YYYYMMDD.HHMMSS of background time step for DI 
     116      REAL(KIND=dp) :: ditiaustr_date  ! Date YYYYMMDD.HHMMSS of IAU interval start time step 
     117      REAL(KIND=dp) :: ditiaufin_date  ! Date YYYYMMDD.HHMMSS of IAU interval final time step 
     118 
    118119      REAL(wp) :: znorm        ! Normalization factor for IAU weights 
    119120      REAL(wp) :: ztotwgt      ! Value of time-integrated IAU weights (should be equal to one) 
    … …  
    177178      icycper = nitend      - nit000      + 1  ! Cycle interval length 
    178179 
    179       CALL calc_date( nit000, nitend     , ndate0, iitend_date    )     ! Date of final time step 
    180       CALL calc_date( nit000, nitbkg_r   , ndate0, iitbkg_date    )     ! Background time for Jb referenced to ndate0 
    181       CALL calc_date( nit000, nitdin_r   , ndate0, iitdin_date    )     ! Background time for DI referenced to ndate0 
    182       CALL calc_date( nit000, nitiaustr_r, ndate0, iitiaustr_date )     ! IAU start time referenced to ndate0 
    183       CALL calc_date( nit000, nitiaufin_r, ndate0, iitiaufin_date )     ! IAU end time referenced to ndate0 
    184       ! 
     180      ! Date of final time step 
     181      CALL calc_date( nitend, ditend_date ) 
     182 
     183      ! Background time for Jb referenced to ndate0 
     184      CALL calc_date( nitbkg_r, ditbkg_date ) 
     185 
     186      ! Background time for DI referenced to ndate0 
     187      CALL calc_date( nitdin_r, ditdin_date ) 
     188 
     189      ! IAU start time referenced to ndate0 
     190      CALL calc_date( nitiaustr_r, ditiaustr_date ) 
     191 
     192      ! IAU end time referenced to ndate0 
     193      CALL calc_date( nitiaufin_r, ditiaufin_date ) 
     194 
    185195      IF(lwp) THEN 
    186196         WRITE(numout,*) 
    … …  
    197207         WRITE(numout,*) '       ndastp         = ', ndastp 
    198208         WRITE(numout,*) '       ndate0         = ', ndate0 
    199          WRITE(numout,*) '       iitend_date    = ', iitend_date 
    200          WRITE(numout,*) '       iitbkg_date    = ', iitbkg_date 
    201          WRITE(numout,*) '       iitdin_date    = ', iitdin_date 
    202          WRITE(numout,*) '       iitiaustr_date = ', iitiaustr_date 
    203          WRITE(numout,*) '       iitiaufin_date = ', iitiaufin_date 
     209         WRITE(numout,*) '       nn_time0       = ', nn_time0 
     210         WRITE(numout,*) '       ditend_date    = ', ditend_date 
     211         WRITE(numout,*) '       ditbkg_date    = ', ditbkg_date 
     212         WRITE(numout,*) '       ditdin_date    = ', ditdin_date 
     213         WRITE(numout,*) '       ditiaustr_date = ', ditiaustr_date 
     214         WRITE(numout,*) '       ditiaufin_date = ', ditiaufin_date 
    204215      ENDIF 
    205216 
    … …  
    359370            WRITE(numout,*)  
    360371            WRITE(numout,*) 'asm_inc_init : Assimilation increments valid ', & 
    361                &            ' between dates ', NINT( z_inc_dateb ),' and ',  & 
    362                &            NINT( z_inc_datef ) 
     372               &            ' between dates ', z_inc_dateb,' and ',  & 
     373               &            z_inc_datef 
    363374            WRITE(numout,*) '~~~~~~~~~~~~' 
    364375         ENDIF 
    365376 
    366          IF (     ( NINT( z_inc_dateb ) < ndastp      ) & 
    367             & .OR.( NINT( z_inc_datef ) > iitend_date ) ) & 
     377         IF (     ( z_inc_dateb < ndastp + nn_time0*0.0001_wp ) & 
     378            & .OR.( z_inc_datef > ditend_date ) ) & 
    368379            & CALL ctl_warn( ' Validity time of assimilation increments is ', & 
    369380            &                ' outside the assimilation interval' ) 
    370381 
    371          IF ( ( ln_asmdin ).AND.( NINT( zdate_inc ) /= iitdin_date ) ) & 
     382         IF ( ( ln_asmdin ).AND.( zdate_inc /= ditdin_date ) ) & 
    372383            & CALL ctl_warn( ' Validity time of assimilation increments does ', & 
    373384            &                ' not agree with Direct Initialization time' ) 
    … …  
    485496         IF(lwp) THEN 
    486497            WRITE(numout,*)  
    487             WRITE(numout,*) 'asm_inc_init : Assimilation background state valid at : ', NINT( zdate_bkg ) 
     498            WRITE(numout,*) 'asm_inc_init : Assimilation background state valid at : ', & 
     499               &  zdate_bkg 
    488500            WRITE(numout,*) '~~~~~~~~~~~~' 
    489501         ENDIF 
    490502         ! 
    491          IF ( NINT( zdate_bkg ) /= iitdin_date ) & 
     503         IF ( zdate_bkg /= ditdin_date ) & 
    492504            & CALL ctl_warn( ' Validity time of assimilation background state does', & 
    493505            &                ' not agree with Direct Initialization time' ) 
    … …  
    517529      ! 
    518530   END SUBROUTINE asm_inc_init 
    519  
    520  
    521    SUBROUTINE calc_date( kit000, kt, kdate0, kdate ) 
    522       !!---------------------------------------------------------------------- 
    523       !!                    ***  ROUTINE calc_date  *** 
    524       !!           
    525       !! ** Purpose : Compute the calendar date YYYYMMDD at a given time step. 
    526       !! 
    527       !! ** Method  : Compute the calendar date YYYYMMDD at a given time step. 
    528       !! 
    529       !! ** Action  :  
    530       !!---------------------------------------------------------------------- 
    531       INTEGER, INTENT(IN) :: kit000  ! Initial time step 
    532       INTEGER, INTENT(IN) :: kt      ! Current time step referenced to kit000 
    533       INTEGER, INTENT(IN) :: kdate0  ! Initial date 
    534       INTEGER, INTENT(OUT) :: kdate  ! Current date reference to kdate0 
    535       ! 
    536       INTEGER :: iyea0    ! Initial year 
    537       INTEGER :: imon0    ! Initial month 
    538       INTEGER :: iday0    ! Initial day 
    539       INTEGER :: iyea     ! Current year 
    540       INTEGER :: imon     ! Current month 
    541       INTEGER :: iday     ! Current day 
    542       INTEGER :: idaystp  ! Number of days between initial and current date 
    543       INTEGER :: idaycnt  ! Day counter 
    544  
    545       INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year 
    546  
    547       !----------------------------------------------------------------------- 
    548       ! Compute the calendar date YYYYMMDD 
    549       !----------------------------------------------------------------------- 
    550  
    551       ! Initial date 
    552       iyea0 =   kdate0 / 10000 
    553       imon0 = ( kdate0 - ( iyea0 * 10000 ) ) / 100 
    554       iday0 =   kdate0 - ( iyea0 * 10000 ) - ( imon0 * 100 )  
    555  
    556       ! Check that kt >= kit000 - 1 
    557       IF ( kt < kit000 - 1 ) CALL ctl_stop( ' kt must be >= kit000 - 1') 
    558  
    559       ! If kt = kit000 - 1 then set the date to the restart date 
    560       IF ( kt == kit000 - 1 ) THEN 
    561          kdate = ndastp 
    562          RETURN 
    563       ENDIF 
    564  
    565       ! Compute the number of days from the initial date 
    566       idaystp = INT( REAL( kt - kit000 ) * rdt / 86400. ) 
    567     
    568       iday    = iday0 
    569       imon    = imon0 
    570       iyea    = iyea0 
    571       idaycnt = 0 
    572  
    573       CALL calc_month_len( iyea, imonth_len ) 
    574  
    575       DO WHILE ( idaycnt < idaystp ) 
    576          iday = iday + 1 
    577          IF ( iday > imonth_len(imon) )  THEN 
    578             iday = 1 
    579             imon = imon + 1 
    580          ENDIF 
    581          IF ( imon > 12 ) THEN 
    582             imon = 1 
    583             iyea = iyea + 1 
    584             CALL calc_month_len( iyea, imonth_len )  ! update month lengths 
    585          ENDIF                  
    586          idaycnt = idaycnt + 1 
    587       END DO 
    588       ! 
    589       kdate = iyea * 10000 + imon * 100 + iday 
    590       ! 
    591    END SUBROUTINE 
    592  
    593  
    594    SUBROUTINE calc_month_len( iyear, imonth_len ) 
    595       !!---------------------------------------------------------------------- 
    596       !!                    ***  ROUTINE calc_month_len  *** 
    597       !!           
    598       !! ** Purpose : Compute the number of days in a months given a year. 
    599       !! 
    600       !! ** Method  :  
    601       !!---------------------------------------------------------------------- 
    602       INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year 
    603       INTEGER :: iyear         !: year 
    604       !!---------------------------------------------------------------------- 
    605       ! 
    606       ! length of the month of the current year (from nleapy, read in namelist) 
    607       IF ( nleapy < 2 ) THEN  
    608          imonth_len(:) = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) 
    609          IF ( nleapy == 1 ) THEN   ! we are using calendar with leap years 
    610             IF ( MOD(iyear, 4) == 0 .AND. ( MOD(iyear, 400) == 0 .OR. MOD(iyear, 100) /= 0 ) ) THEN 
    611                imonth_len(2) = 29 
    612             ENDIF 
    613          ENDIF 
    614       ELSE 
    615          imonth_len(:) = nleapy   ! all months with nleapy days per year 
    616       ENDIF 
    617       ! 
    618    END SUBROUTINE 
    619  
    620  
    621531   SUBROUTINE tra_asm_inc( kt ) 
    622532      !!---------------------------------------------------------------------- 
    … …  
    721631!!gm 
    722632 
    723             IF( ln_zps .AND. .NOT. lk_c1d ) THEN      ! Partial steps: before horizontal gradient 
    724                IF(ln_isfcav) THEN                        ! ocean cavities: top and bottom cells (ISF) 
    725                   CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv, gtui, gtvi,     & 
    726                      &                            rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
    727                      &                     grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) 
    728                ELSE                                      ! no ocean cavities: bottom cells 
    729                   CALL zps_hde    ( kt, jpts, tsb, gtsu, gtsv,        &  !  
    730                      &                        rhd, gru , grv          )  ! of t, s, rd at the last ocean level 
    731                ENDIF 
    732             ENDIF 
    733             ! 
     633            IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav)      & 
     634               &  CALL zps_hde    ( kt, jpts, tsb, gtsu, gtsv,        &  ! Partial steps: before horizontal gradient 
     635               &                              rhd, gru , grv          )  ! of t, s, rd at the last ocean level 
     636            IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav)      & 
     637               &  CALL zps_hde_isf( nit000, jpts, tsb, gtsu, gtsv, gtui, gtvi,    &    ! Partial steps for top cell (ISF) 
     638               &                                  rhd, gru , grv , grui, grvi     )    ! of t, s, rd at the last ocean level 
     639 
     640#if defined key_zdfkpp 
     641            CALL eos( tsn, rhd, fsdept_n(:,:,:) )                      ! Compute rhd 
     642!!gm fabien            CALL eos( tsn, rhd )                      ! Compute rhd 
     643#endif 
     644 
    734645            DEALLOCATE( t_bkginc ) 
    735646            DEALLOCATE( s_bkginc ) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r6060 r6069  
    5454   !!---------------------------------------------------------------------- 
    5555   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    56    !! $Id$  
     56   !! $Id$ 
    5757   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5858   !!---------------------------------------------------------------------- 
    … …  
    321321      ENDIF 
    322322 
    323       IF ( nsec_day == NINT(0.5_wp * rdttra(1)) .AND. zflag==1 ) THEN 
     323      IF ( (nsec_day == NINT(0.5_wp * rdttra(1)) .OR. kt==nit000) .AND. zflag==1 ) THEN 
    324324        ! 
    325         kt_tide = kt 
     325        kt_tide = kt - (nsec_day - 0.5_wp * rdttra(1))/rdttra(1) 
    326326        ! 
    327327        IF(lwp) THEN 
    … …  
    437437            ! We refresh nodal factors every day below 
    438438            ! This should be done somewhere else 
    439             IF ( nsec_day == NINT(0.5_wp * rdttra(1)) .AND. lk_first_btstp ) THEN 
    440                ! 
    441                kt_tide = kt                
     439            IF ( ( nsec_day == NINT(0.5_wp * rdttra(1)) .OR. kt==nit000 ) .AND. lk_first_btstp ) THEN 
     440               ! 
     441               kt_tide = kt - (nsec_day - 0.5_wp * rdttra(1))/rdttra(1) 
    442442               ! 
    443443               IF(lwp) THEN 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r6060 r6069  
    9191      ! ----------------------------------------------------------------------- 
    9292!!gm replace these lines : 
    93       z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1e2t(:,:) ) / rau0 
     93      z_cflxemp = SUM ( ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * bdytmask(:,:) * e1e2t(:,:) ) / rau0 
    9494      IF( lk_mpp )   CALL mpp_sum( z_cflxemp )     ! sum over the global domain 
    9595!!gm   by : 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90

    r6060 r6069  
    458458      ENDIF 
    459459 
    460       IF( nn_timing == 1 )   CALL timing_start('dia_fwb') 
     460      IF( nn_timing == 1 )   CALL timing_stop('dia_fwb') 
    461461 
    462462 9005 FORMAT(1X,A,ES24.16) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r5930 r6069  
    135135      DO jk=1,nb_ana 
    136136       DO ji=1,jpmax_harmo 
    137           IF (TRIM(tname(jk)) .eq. Wave(ji)%cname_tide) THEN 
     137          IF (TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN 
    138138             name(jk) = ji 
    139139             EXIT 
    … …  
    194194                  DO ji = 1,jpi 
    195195                     ! Elevation 
    196                      ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj)         
    197                      ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 
    198                      ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 
     196                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*ssmask (ji,jj)         
     197                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*ssumask(ji,jj) 
     198                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*ssvmask(ji,jj) 
    199199                  END DO 
    200200               END DO 
    … …  
    324324               X1= ana_amp(ji,jj,jh,1) 
    325325               X2=-ana_amp(ji,jj,jh,2) 
    326                out_u(ji,jj,       jh) = X1 * umask_i(ji,jj) 
    327                out_u(ji,jj,nb_ana+jh) = X2 * umask_i(ji,jj) 
     326               out_u(ji,jj,       jh) = X1 * ssumask(ji,jj) 
     327               out_u(ji,jj,nb_ana+jh) = X2 * ssumask(ji,jj) 
    328328            ENDDO 
    329329         ENDDO 
    … …  
    358358               X1=ana_amp(ji,jj,jh,1) 
    359359               X2=-ana_amp(ji,jj,jh,2) 
    360                out_v(ji,jj,       jh)=X1 * vmask_i(ji,jj) 
    361                out_v(ji,jj,nb_ana+jh)=X2 * vmask_i(ji,jj) 
     360               out_v(ji,jj,       jh)=X1 * ssvmask(ji,jj) 
     361               out_v(ji,jj,nb_ana+jh)=X2 * ssvmask(ji,jj) 
    362362            END DO 
    363363         END DO 
    … …  
    488488            DO jj_sd = ji_sd, ninco 
    489489               zval2 = ABS(ztmp3(ji_sd,jj_sd)) 
    490                IF( zval2.GE.zval1 )THEN 
     490               IF( zval2 >= zval1 )THEN 
    491491                  ipivot(ji_sd) = jj_sd 
    492492                  zval1         = zval2 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r6060 r6069  
    4646   REAL(wp) ::   frc_wn_t, frc_wn_s    ! global forcing trends 
    4747   ! 
    48    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   surf          , ssh_ini          ! 
     48   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   surf  
     49   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   surf_ini      , ssh_ini          ! 
    4950   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   ssh_hc_loc_ini, ssh_sc_loc_ini   ! 
    5051   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   hc_loc_ini, sc_loc_ini, e3t_ini  ! 
    … …  
    99100      IF( ln_rnf_sal)   z_frc_trd_s = z_frc_trd_s + glob_sum( rnf_tsc(:,:,jp_sal) * surf(:,:) ) 
    100101      ! Add ice shelf heat & salt input 
    101       IF( nn_isf .GE. 1 )  THEN 
    102           z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
    103           z_frc_trd_s = z_frc_trd_s + glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
    104       ENDIF 
    105  
     102      IF( ln_isf    ) z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
    106103      ! Add penetrative solar radiation 
    107104      IF( ln_traqsr )   z_frc_trd_t = z_frc_trd_t + r1_rau0_rcp * glob_sum( qsr     (:,:) * surf(:,:) ) 
    … …  
    137134      ! 2 -  Content variations ! 
    138135      ! ------------------------ ! 
     136      ! glob_sum_full is needed because you keep the full interior domain to compute the sum (iscpl) 
    139137      zdiff_v2 = 0._wp 
    140138      zdiff_hc = 0._wp 
    … …  
    142140 
    143141      ! volume variation (calculated with ssh) 
    144       zdiff_v1 = glob_sum( surf(:,:) * ( sshn(:,:) - ssh_ini(:,:) ) ) 
     142      zdiff_v1 = glob_sum_full( surf(:,:) * sshn(:,:) - surf_ini(:,:) * ssh_ini(:,:) ) 
    145143 
    146144      ! heat & salt content variation (associated with ssh) 
    … …  
    157155            z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) )  
    158156         END IF 
    159          z_ssh_hc = glob_sum( z2d0 )  
    160          z_ssh_sc = glob_sum( z2d1 )  
     157         z_ssh_hc = glob_sum_full( z2d0 )  
     158         z_ssh_sc = glob_sum_full( z2d1 )  
    161159      ENDIF 
    162160 
    163161      DO jk = 1, jpkm1 
    164162         ! volume variation (calculated with scale factors) 
    165          zdiff_v2 = zdiff_v2 + glob_sum( surf(:,:) * tmask(:,:,jk)            & 
    166             &                           * ( e3t_n(:,:,jk) - e3t_ini(:,:,jk) ) ) 
     163         zdiff_v2 = zdiff_v2 + glob_sum_full( surf(:,:) * tmask(:,:,jk)            & 
     164            &                           * e3t_n(:,:,jk) - surf_ini(:,:) * e3t_ini(:,:,jk) ) 
    167165         ! heat content variation 
    168          zdiff_hc = zdiff_hc + glob_sum(  surf(:,:) * tmask(:,:,jk)                                   &  
    169             &                           * ( e3t_n(:,:,jk) * tsn(:,:,jk,jp_tem) - hc_loc_ini(:,:,jk) ) ) 
     166         zdiff_hc = zdiff_hc + glob_sum_full(  surf(:,:) * tmask(:,:,jk)                                   &  
     167            &                           * e3t_n(:,:,jk) * tsn(:,:,jk,jp_tem) - surf_ini(:,:) * hc_loc_ini(:,:,jk) ) ) 
    170168         ! salt content variation 
    171          zdiff_sc = zdiff_sc + glob_sum(  surf(:,:) * tmask(:,:,jk)                                   & 
    172             &                           * ( e3t_n(:,:,jk) * tsn(:,:,jk,jp_sal) - sc_loc_ini(:,:,jk) ) ) 
    173       END DO 
     169         zdiff_sc = zdiff_sc + glob_sum_full( surf    (:,:) * tmask(:,:,jk)                           & 
     170                                        * e3t_n(:,:,jk) * tsn(:,:,jk,jp_sal) - surf_ini(:,:) * sc_loc_ini(:,:,jk) ) 
     171      ENDDO 
    174172 
    175173      ! Substract forcing from heat content, salt content and volume variations 
    … …  
    190188      zvol_tot = 0._wp                    ! total ocean volume (calculated with scale factors) 
    191189      DO jk = 1, jpkm1 
    192          zvol_tot  = zvol_tot + glob_sum( surf(:,:) * tmask(:,:,jk) * e3t_n(:,:,jk) ) 
     190         zvol_tot  = zvol_tot + glob_sum_full( surf(:,:) * tmask(:,:,jk) * e3t_n(:,:,jk) ) 
    193191      END DO 
    194192 
    … …  
    203201        CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content variation (psu) 
    204202        CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content variation (1.e20 J)  
    205         CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content variation (psu*km3) 
    206         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
     203        CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9   )              ! Salt content variation (psu*km3) 
     204        CALL iom_put( 'bgvolssh' , zdiff_v1  * 1.e-9   )              ! volume ssh variation (km3)   
    207205        CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    208206        CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    … …  
    260258              CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 
    261259           ENDIF 
     260           CALL iom_get( numror, jpdom_autoglo, 'surf_ini', surf_ini ) ! ice sheet coupling 
    262261           CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini ) 
    263262           CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini ) 
    … …  
    272271          IF(lwp) WRITE(numout,*) ' dia_hsb at initial state ' 
    273272          IF(lwp) WRITE(numout,*) '~~~~~~~' 
    274           ssh_ini(:,:) = sshn(:,:)                                       ! initial ssh 
     273          surf_ini(:,:) = e1e2t(:,:) * tmask_i(:,:)         ! initial ocean surface 
     274          ssh_ini(:,:) = sshn(:,:)                          ! initial ssh 
    275275          DO jk = 1, jpk 
    276              e3t_ini   (:,:,jk) = e3t_n(:,:,jk)                        ! initial vertical scale factors 
    277              hc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_tem) * e3t_n(:,:,jk)   ! initial heat content 
    278              sc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_sal) * e3t_n(:,:,jk)   ! initial salt content 
     276             ! if ice sheet/oceqn coupling, need to mask ini variables here (mask could change at the next NEMO instance). 
     277             e3t_ini   (:,:,jk) = e3t_n(:,:,jk)                      * tmask(:,:,jk)  ! initial vertical scale factors 
     278             hc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_tem) * e3t_n(:,:,jk) * tmask(:,:,jk)  ! initial heat content 
     279             sc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_sal) * e3t_n(:,:,jk) * tmask(:,:,jk)  ! initial salt content 
    279280          END DO 
    280281          frc_v = 0._wp                                           ! volume       trend due to forcing 
    … …  
    311312           CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 
    312313        ENDIF 
     314        CALL iom_rstput( kt, nitrst, numrow, 'surf_ini', surf_ini )      ! ice sheet coupling 
    313315        CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini ) 
    314316        CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini ) 
    … …  
    378380      ! 1 - Allocate memory ! 
    379381      ! ------------------- ! 
    380       ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), & 
    381          &      e3t_ini(jpi,jpj,jpk), surf(jpi,jpj),  ssh_ini(jpi,jpj), STAT=ierror ) 
     382      ALLOCATE( hc_loc_ini(jpi,jpj,jpk), sc_loc_ini(jpi,jpj,jpk), surf_ini(jpi,jpj), & 
     383         &      e3t_ini(jpi,jpj,jpk), surf(jpi,jpj),  ssh_ini(jpi,jpj), STAT=ierror  ) 
    382384      IF( ierror > 0 ) THEN 
    383385         CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r6060 r6069  
    4545   USE in_out_manager  ! I/O manager 
    4646   USE diadimg         ! dimg direct access file format output 
     47   USE diatmb          ! Top,middle,bottom output 
     48   USE dia25h          ! 25h Mean output 
    4749   USE iom 
    4850   USE ioipsl 
    … …  
    5557   USE lib_mpp         ! MPP library 
    5658   USE timing          ! preformance summary 
     59   USE diurnal_bulk    ! diurnal warm layer 
     60   USE cool_skin       ! Cool skin 
    5761   USE wrk_nemo        ! working array 
    5862 
    … …  
    369373      CALL wrk_dealloc( jpi , jpj, jpk , z3d ) 
    370374      ! 
     375      ! If we want tmb values  
     376 
     377      IF (ln_diatmb) THEN 
     378         CALL dia_tmb  
     379      ENDIF  
     380      IF (ln_dia25h) THEN 
     381         CALL dia_25h( kt ) 
     382      ENDIF  
     383 
    371384      IF( nn_timing == 1 )   CALL timing_stop('dia_wri') 
    372385      ! 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r6060 r6069  
    1111   !!                 ! 2004-01  (A.M. Treguier) new calculation based on adatrj 
    1212   !!                 ! 2006-08  (G. Madec)  surface module major update 
     13   !!                 ! 2015-11  (D. Lea) Allow non-zero initial time of day 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    9596      nday    =   ndastp - (nyear * 10000) - ( nmonth * 100 ) 
    9697 
    97       CALL ymds2ju( nyear, nmonth, nday, 0.0, fjulday )  ! we assume that we start run at 00:00 
     98      nhour   =   nn_time0 / 100 
     99      nminute = ( nn_time0 - nhour * 100 ) 
     100 
     101      CALL ymds2ju( nyear, nmonth, nday, nhour*3600._wp+nminute*60._wp, fjulday )   
    98102      IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday )   fjulday = REAL(NINT(fjulday),wp)   ! avoid truncation error 
    99       fjulday = fjulday + 1.                             ! move back to the day at nit000 (and not at nit000 - 1) 
     103      IF( nn_time0*3600 - ndt05 .lt. 0 ) fjulday = fjulday + 1.                    ! move back to the day at nit000 (and not at nit000 - 1) 
    100104 
    101105      nsec1jan000 = 0 
    … …  
    118122      !compute number of days between last monday and today 
    119123      CALL ymds2ju( 1900, 01, 01, 0.0, zjul )  ! compute julian day value of 01.01.1900 (our reference that was a Monday) 
    120       inbday = NINT(fjulday - zjul)            ! compute nb day between  01.01.1900 and current day 
     124      inbday = FLOOR(fjulday - zjul)            ! compute nb day between  01.01.1900 and start of current day 
    121125      idweek = MOD(inbday, 7)                  ! compute nb day between last monday and current day 
     126      IF (idweek .lt. 0) idweek=idweek+7       ! Avoid negative values for dates before 01.01.1900 
    122127 
    123128      ! number of seconds since the beginning of current year/month/week/day at the middle of the time-step 
    124       nsec_year  = nday_year * nsecd - ndt05   ! 1 time step before the middle of the first time step 
    125       nsec_month = nday      * nsecd - ndt05   ! because day will be called at the beginning of step 
    126       nsec_week  = idweek    * nsecd - ndt05 
    127       nsec_day   =             nsecd - ndt05 
     129      IF (nhour*3600+nminute*60-ndt05 .gt. 0) THEN 
     130         ! 1 timestep before current middle of first time step is still the same day 
     131         nsec_year  = (nday_year-1) * nsecd + nhour*3600+nminute*60 - ndt05  
     132         nsec_month = (nday-1)      * nsecd + nhour*3600+nminute*60 - ndt05     
     133      ELSE 
     134         ! 1 time step before the middle of the first time step is the previous day  
     135         nsec_year  = nday_year * nsecd + nhour*3600+nminute*60 - ndt05  
     136         nsec_month = nday      * nsecd + nhour*3600+nminute*60 - ndt05    
     137      ENDIF 
     138      nsec_week  = idweek    * nsecd + nhour*3600+nminute*60 - ndt05 
     139      nsec_day   =             nhour*3600+nminute*60 - ndt05  
     140      IF( nsec_day .lt. 0 ) nsec_day = nsec_day + nsecd 
     141      IF( nsec_week .lt. 0 ) nsec_week = nsec_week + nsecd*7 
    128142 
    129143      ! control print 
    130       IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i8,a,i8)')' =======>> 1/2 time step before the start of the run DATE Y/M/D = ',   & 
    131            &                   nyear, '/', nmonth, '/', nday, '  nsec_day:', nsec_day, '  nsec_week:', nsec_week 
     144      IF(lwp) WRITE(numout,'(a,i6,a,i2,a,i2,a,i8,a,i8,a,i8,a,i8)')' =======>> 1/2 time step before the start of the run DATE Y/M/D = ',   & 
     145           &                   nyear, '/', nmonth, '/', nday, '  nsec_day:', nsec_day, '  nsec_week:', nsec_week, '  & 
     146           &                   nsec_month:', nsec_month , '  nsec_year:' , nsec_year 
    132147 
    133148      ! Up to now, calendar parameters are related to the end of previous run (nit000-1) 
    … …  
    302317      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag 
    303318      ! 
    304       REAL(wp) ::   zkt, zndastp 
     319      REAL(wp) ::   zkt, zndastp, zdayfrac, ksecs, ktime 
     320      INTEGER  ::   ihour, iminute 
    305321      !!---------------------------------------------------------------------- 
    306322 
    … …  
    327343            ! define ndastp and adatrj 
    328344            IF ( nrstdt == 2 ) THEN 
    329                ! read the parameters correspondting to nit000 - 1 (last time step of previous run) 
     345               ! read the parameters corresponding to nit000 - 1 (last time step of previous run) 
    330346               CALL iom_get( numror, 'ndastp', zndastp ) 
    331347               ndastp = NINT( zndastp ) 
    332348               CALL iom_get( numror, 'adatrj', adatrj  ) 
     349          CALL iom_get( numror, 'ntime', ktime ) 
     350          nn_time0=INT(ktime) 
     351               ! calculate start time in hours and minutes 
     352          zdayfrac=adatrj-INT(adatrj) 
     353          ksecs = NINT(zdayfrac*86400)        ! Nearest second to catch rounding errors in adatrj          
     354          ihour = INT(ksecs/3600) 
     355          iminute = ksecs/60-ihour*60 
     356            
     357               ! Add to nn_time0 
     358               nhour   =   nn_time0 / 100 
     359               nminute = ( nn_time0 - nhour * 100 ) 
     360          nminute=nminute+iminute 
     361           
     362          IF( nminute >= 60 ) THEN 
     363             nminute=nminute-60 
     364        nhour=nhour+1 
     365          ENDIF 
     366          nhour=nhour+ihour 
     367          IF( nhour >= 24 ) THEN 
     368        nhour=nhour-24 
     369             adatrj=adatrj+1 
     370          ENDIF           
     371          nn_time0 = nhour * 100 + nminute 
     372          adatrj = INT(adatrj)                    ! adatrj set to integer as nn_time0 updated           
    333373            ELSE 
    334                ! parameters correspondting to nit000 - 1 (as we start the step loop with a call to day) 
    335                ndastp = ndate0 - 1     ! ndate0 read in the namelist in dom_nam, we assume that we start run at 00:00 
     374               ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) 
     375               ndastp = ndate0        ! ndate0 read in the namelist in dom_nam 
     376               nhour   =   nn_time0 / 100 
     377               nminute = ( nn_time0 - nhour * 100 ) 
     378               IF( nhour*3600+nminute*60-ndt05 .lt. 0 )  ndastp=ndastp-1      ! Start hour is specified in the namelist (default 0) 
    336379               adatrj = ( REAL( nit000-1, wp ) * rdttra(1) ) / rday 
    337380               ! note this is wrong if time step has changed during run 
    338381            ENDIF 
    339382         ELSE 
    340             ! parameters correspondting to nit000 - 1 (as we start the step loop with a call to day) 
    341             ndastp = ndate0 - 1        ! ndate0 read in the namelist in dom_nam, we assume that we start run at 00:00 
     383            ! parameters corresponding to nit000 - 1 (as we start the step loop with a call to day) 
     384            ndastp = ndate0           ! ndate0 read in the namelist in dom_nam 
     385            nhour   =   nn_time0 / 100 
     386       nminute = ( nn_time0 - nhour * 100 ) 
     387            IF( nhour*3600+nminute*60-ndt05 .lt. 0 )  ndastp=ndastp-1      ! Start hour is specified in the namelist (default 0) 
    342388            adatrj = ( REAL( nit000-1, wp ) * rdttra(1) ) / rday 
    343389         ENDIF 
    … …  
    348394            WRITE(numout,*) '   date ndastp                                      : ', ndastp 
    349395            WRITE(numout,*) '   number of elapsed days since the begining of run : ', adatrj 
     396       WRITE(numout,*) '   nn_time0                                         : ',nn_time0 
    350397            WRITE(numout,*) 
    351398         ENDIF 
    … …  
    363410         CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj            )   ! number of elapsed days since 
    364411         !                                                                     ! the begining of the run [s] 
     412    CALL iom_rstput( kt, nitrst, numrow, 'ntime'  , REAL( nn_time0, wp) ) ! time 
    365413      ENDIF 
    366414      ! 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r6062 r6069  
    3333   REAL(wp), PUBLIC ::   rn_bathy        !: depth of flat bottom (active if nn_bathy=0; if =0 depth=jpkm1) 
    3434   REAL(wp), PUBLIC ::   rn_hmin         !: minimum ocean depth (>0) or minimum number of ocean levels (<0) 
     35   REAL(wp), PUBLIC ::   rn_isfhmin      !: threshold to discriminate grounded ice to floating ice 
    3536   REAL(wp), PUBLIC ::   rn_e3zps_min    !: miminum thickness for partial steps (meters) 
    3637   REAL(wp), PUBLIC ::   rn_e3zps_rat    !: minimum thickness ration for partial steps 
    … …  
    4445   INTEGER , PUBLIC ::   nn_closea       !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 
    4546   INTEGER , PUBLIC ::   nn_euler        !: =0 start with forward time step or not (=1) 
     47   LOGICAL , PUBLIC ::   ln_iscpl       !: coupling with ice sheet 
    4648   LOGICAL , PUBLIC ::   ln_crs          !: Apply grid coarsening to dynamical model output or online passive tracers 
    4749 
    … …  
    237239   !! --------------------------------------------------------------------- 
    238240   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbathy             !: number of ocean level (=0, 1, ... , jpk-1) 
    239    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt, mbku, mbkv   !: vertical index of the bottom last T-, U- & V ocean level 
     241   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt               !: vertical index of the bottom last T- ocean level 
     242   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbku, mbkv         !: vertical index of the bottom last U- and W- ocean level 
    240243   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bathy              !: ocean depth (meters) 
    241    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_i, umask_i, vmask_i, fmask_i !: interior domain T-point mask 
     244   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_i            !: interior domain T-point mask 
     245   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_h            !: internal domain T-point mask (Figure 8.5 NEMO book) 
    242246 
    243247   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   misfdep                 !: top first ocean level                (ISF) 
    244248   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mikt, miku, mikv, mikf  !: first wet T-, U-, V-, F- ocean level (ISF) 
    245249   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   risfdep                 !: Iceshelf draft                       (ISF) 
    246    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssmask                   !: surface domain T-point mask  
    247  
     250 
     251   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssmask, ssumask, ssvmask, ssfmask    !: surface mask at T-,U-, V- and F-pts 
    248252   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
    249253   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask        !: land/ocean mask at WT-, WU- and WV-pts 
    … …  
    257261   INTEGER , PUBLIC ::   nmonth        !: current month 
    258262   INTEGER , PUBLIC ::   nday          !: current day of the month 
     263   INTEGER , PUBLIC ::   nhour         !: current hour 
     264   INTEGER , PUBLIC ::   nminute       !: current minute 
    259265   INTEGER , PUBLIC ::   ndastp        !: time step date in yyyymmdd format 
    260266   INTEGER , PUBLIC ::   nday_year     !: current day counted from jan 1st of the current year 
    … …  
    293299   !!---------------------------------------------------------------------- 
    294300   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    295    !! $Id$  
     301   !! $Id$ 
    296302   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    297303   !!---------------------------------------------------------------------- 
    … …  
    368374         &      hift  (jpi,jpj) , hifu  (jpi,jpj) , rx1(jpi,jpj) , STAT=ierr(8) ) 
    369375 
    370       ALLOCATE( mbathy(jpi,jpj) , bathy(jpi,jpj) ,                                      & 
    371          &     tmask_i(jpi,jpj) , umask_i(jpi,jpj), vmask_i(jpi,jpj), fmask_i(jpi,jpj), & 
    372          &     mbkt   (jpi,jpj) , mbku (jpi,jpj) , mbkv(jpi,jpj) , STAT=ierr(9) ) 
     376      ALLOCATE( mbathy(jpi,jpj) , bathy  (jpi,jpj) ,                                       & 
     377         &     tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                                       &  
     378         &     ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 
     379         &     mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) , STAT=ierr(9) ) 
    373380 
    374381! (ISF) Allocation of basic array    
    375       ALLOCATE( misfdep(jpi,jpj) , risfdep(jpi,jpj),                   & 
    376          &      mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj) ,           & 
    377          &      mikf(jpi,jpj), ssmask(jpi,jpj), STAT=ierr(10) ) 
     382      ALLOCATE( misfdep(jpi,jpj) , risfdep(jpi,jpj),     & 
     383         &     mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj) ,           & 
     384         &     mikf(jpi,jpj), STAT=ierr(10) ) 
    378385 
    379386      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk),     &  

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r6060 r6069  
    140140      ! 
    141141                             CALL dom_stp       ! time step 
    142       IF( nmsh /= 0      )   CALL dom_wri       ! Create a domain file 
     142      IF( nmsh /= 0 .AND. .NOT. ln_iscpl )                         CALL dom_wri      ! Create a domain file 
     143      IF( nmsh /= 0 .AND.       ln_iscpl .AND. .NOT. ln_rstart )   CALL dom_wri      ! Create a domain file 
    143144      IF( .NOT.ln_rstart )   CALL dom_ctl       ! Domain control 
    144145      ! 
    … …  
    159160      !!---------------------------------------------------------------------- 
    160161      USE ioipsl 
    161       NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               & 
    162          &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
    163          &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
    164          &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler 
    165       NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin,   & 
    166          &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,                  & 
    167          &             rn_rdtmax, rn_rdth     , nn_closea , ln_crs,    & 
    168          &             jphgr_msh, & 
    169          &             ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, & 
    170          &             ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, & 
     162      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,                 & 
     163                       nn_no   , cn_exp   , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl ,     & 
     164         &             nn_it000, nn_itend , nn_date0    , nn_time0     , nn_leapy  , nn_istate ,     & 
     165         &             nn_stock, nn_write , ln_dimgnnn  , ln_mskland   , ln_clobber, nn_chunksz,     & 
     166         &             nn_euler, ln_cfmeta, ln_iscpl 
     167      NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, rn_isfhmin, & 
     168         &             nn_acc   , rn_atfp , rn_rdt      , rn_rdtmin   ,                              & 
     169         &             rn_rdtmax, rn_rdth , nn_closea   , ln_crs      ,                              & 
     170         &             jphgr_msh,                                                                    & 
     171         &             ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m,                         & 
     172         &             ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh,                  & 
    171173         &             ppa2, ppkth2, ppacr2 
    172174#if defined key_netcdf4 
    … …  
    202204         WRITE(numout,*) '      number of the last time step    nn_itend   = ', nn_itend 
    203205         WRITE(numout,*) '      initial calendar date aammjj    nn_date0   = ', nn_date0 
     206         WRITE(numout,*) '      initial time of day in hhmm     nn_time0   = ', nn_time0 
    204207         WRITE(numout,*) '      leap year calendar (0/1)        nn_leapy   = ', nn_leapy 
    205208         WRITE(numout,*) '      initial state output            nn_istate  = ', nn_istate 
    … …  
    215218         WRITE(numout,*) '      overwrite an existing file      ln_clobber = ', ln_clobber 
    216219         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz = ', nn_chunksz 
     220         WRITE(numout,*) '      IS coupling at the restart step ln_iscpl   = ', ln_iscpl 
    217221      ENDIF 
    218222 
    … …  
    282286         WRITE(numout,*) '      min depth of the ocean    (>0) or    rn_hmin   = ', rn_hmin 
    283287         WRITE(numout,*) '      min number of ocean level (<0)       ' 
     288         WRITE(numout,*) '      treshold to open the isf cavity   rn_isfhmin   = ', rn_isfhmin, ' (m)' 
    284289         WRITE(numout,*) '      minimum thickness of partial      rn_e3zps_min = ', rn_e3zps_min, ' (m)' 
    285290         WRITE(numout,*) '         step level                     rn_e3zps_rat = ', rn_e3zps_rat 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r6060 r6069  
    506506      CALL iom_close( inum ) 
    507507       
    508 !!gm   THIS is TO BE REMOVED !!!!!!! 
    509  
    510 ! need to be define for the extended grid south of -80S 
    511 ! some point are undefined but you need to have e1 and e2 .NE. 0 
    512       WHERE (e1t==0.0_wp) 
    513          e1t=1.0e2 
    514       END WHERE 
    515       WHERE (e1v==0.0_wp) 
    516          e1v=1.0e2 
    517       END WHERE 
    518       WHERE (e1u==0.0_wp) 
    519          e1u=1.0e2 
    520       END WHERE 
    521       WHERE (e1f==0.0_wp) 
    522          e1f=1.0e2 
    523       END WHERE 
    524       WHERE (e2t==0.0_wp) 
    525          e2t=1.0e2 
    526       END WHERE 
    527       WHERE (e2v==0.0_wp) 
    528          e2v=1.0e2 
    529       END WHERE 
    530       WHERE (e2u==0.0_wp) 
    531          e2u=1.0e2 
    532       END WHERE 
    533       WHERE (e2f==0.0_wp) 
    534          e2f=1.0e2 
    535       END WHERE 
    536 !!gm end 
    537         
    538508    END SUBROUTINE hgr_read 
    539509     

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r6060 r6069  
    174174      ! -------------------- 
    175175      tmask_i(:,:) = ssmask(:,:)            ! (ISH) tmask_i = 1 even on the ice shelf 
     176 
     177      tmask_h(:,:) = 1._wp                 ! 0 on the halo and 1 elsewhere 
    176178      iif = jpreci                         ! ??? 
    177179      iil = nlci - jpreci + 1 
    … …  
    179181      ijl = nlcj - jprecj + 1 
    180182 
    181       tmask_i( 1 :iif,   :   ) = 0._wp      ! first columns 
    182       tmask_i(iil:jpi,   :   ) = 0._wp      ! last  columns (including mpp extra columns) 
    183       tmask_i(   :   , 1 :ijf) = 0._wp      ! first rows 
    184       tmask_i(   :   ,ijl:jpj) = 0._wp      ! last  rows (including mpp extra rows) 
     183      tmask_h( 1 :iif,   :   ) = 0._wp      ! first columns 
     184      tmask_h(iil:jpi,   :   ) = 0._wp      ! last  columns (including mpp extra columns) 
     185      tmask_h(   :   , 1 :ijf) = 0._wp      ! first rows 
     186      tmask_h(   :   ,ijl:jpj) = 0._wp      ! last  rows (including mpp extra rows) 
    185187 
    186188      ! north fold mask 
    … …  
    193195         IF( mjg(nlej) == jpjglo ) THEN                  ! only half of the nlcj-1 row 
    194196            DO ji = iif+1, iil-1 
    195                tmask_i(ji,nlej-1) = tmask_i(ji,nlej-1) * tpol(mig(ji)) 
     197               tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) 
    196198            END DO 
    197199         ENDIF 
    198200      ENDIF 
     201      
     202      tmask_i(:,:) = tmask_i(:,:) * tmask_h(:,:) 
     203 
    199204      IF( jperio == 5 .OR. jperio == 6 ) THEN      ! F-point pivot 
    200205         tpol(     1    :jpiglo) = 0._wp 
    … …  
    216221         END DO 
    217222      END DO 
    218       ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet u point 
     223      ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet cell at u point 
    219224      DO jj = 1, jpjm1 
    220225         DO ji = 1, fs_jpim1   ! vector loop 
    221             umask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
    222             vmask_i(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
     226            ssumask(ji,jj)  = ssmask(ji,jj) * ssmask(ji+1,jj  )  * MIN(1._wp,SUM(umask(ji,jj,:))) 
     227            ssvmask(ji,jj)  = ssmask(ji,jj) * ssmask(ji  ,jj+1)  * MIN(1._wp,SUM(vmask(ji,jj,:))) 
    223228         END DO 
    224229         DO ji = 1, jpim1      ! NO vector opt. 
    225             fmask_i(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
     230            ssfmask(ji,jj) =  ssmask(ji,jj  ) * ssmask(ji+1,jj  )   & 
    226231               &            * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:))) 
    227232         END DO 
    228233      END DO 
    229       CALL lbc_lnk( umask, 'U', 1._wp )      ! Lateral boundary conditions 
    230       CALL lbc_lnk( vmask, 'V', 1._wp ) 
    231       CALL lbc_lnk( fmask, 'F', 1._wp ) 
    232       CALL lbc_lnk( umask_i, 'U', 1._wp )      ! Lateral boundary conditions 
    233       CALL lbc_lnk( vmask_i, 'V', 1._wp ) 
    234       CALL lbc_lnk( fmask_i, 'F', 1._wp ) 
     234      CALL lbc_lnk( umask  , 'U', 1._wp )      ! Lateral boundary conditions 
     235      CALL lbc_lnk( vmask  , 'V', 1._wp ) 
     236      CALL lbc_lnk( fmask  , 'F', 1._wp ) 
     237      CALL lbc_lnk( ssumask, 'U', 1._wp )      ! Lateral boundary conditions 
     238      CALL lbc_lnk( ssvmask, 'V', 1._wp ) 
     239      CALL lbc_lnk( ssfmask, 'F', 1._wp ) 
    235240 
    236241      ! 3. Ocean/land mask at wu-, wv- and w points  

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/domngb.F90

    r5836 r6069  
    2828CONTAINS 
    2929 
    30    SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid ) 
     30   SUBROUTINE dom_ngb( plon, plat, kii, kjj, cdgrid, kkk ) 
    3131      !!---------------------------------------------------------------------- 
    3232      !!                    ***  ROUTINE dom_ngb  *** 
    … …  
    3939      REAL(wp)        , INTENT(in   ) ::   plon, plat   ! longitude,latitude of the point 
    4040      INTEGER         , INTENT(  out) ::   kii, kjj     ! i-,j-index of the closes grid point 
     41      INTEGER         , INTENT(in   ), OPTIONAL :: kkk  ! k-index of the mask level used 
    4142      CHARACTER(len=1), INTENT(in   ) ::   cdgrid       ! grid name 'T', 'U', 'V', 'W' 
    4243      ! 
     44      INTEGER :: ik         ! working level 
    4345      INTEGER , DIMENSION(2) ::   iloc 
    4446      REAL(wp)               ::   zlon, zmini 
    … …  
    5153      ! 
    5254      zmask(:,:) = 0._wp 
     55      ik = 1 
     56      IF ( PRESENT(kkk) ) ik=kkk 
    5357      SELECT CASE( cdgrid ) 
    54       CASE( 'U' )  ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,1) 
    55       CASE( 'V' )  ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,1) 
    56       CASE( 'F' )  ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,1) 
    57       CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,1) 
     58      CASE( 'U' )  ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,ik) 
     59      CASE( 'V' )  ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,ik) 
     60      CASE( 'F' )  ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,ik) 
     61      CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,ik) 
    5862      END SELECT 
    5963 
    60       zlon       = MOD( plon       + 720., 360. )                                     ! plon between    0 and 360 
    61       zglam(:,:) = MOD( zglam(:,:) + 720., 360. )                                     ! glam between    0 and 360 
    62       IF( zlon > 270. )   zlon = zlon - 360.                                          ! zlon between  -90 and 270 
    63       IF( zlon <  90. )   WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360.   ! glam between -180 and 180 
     64      IF (jphgr_msh /= 2 .AND. jphgr_msh /= 3) THEN 
     65         zlon       = MOD( plon       + 720., 360. )                                     ! plon between    0 and 360 
     66         zglam(:,:) = MOD( zglam(:,:) + 720., 360. )                                     ! glam between    0 and 360 
     67         IF( zlon > 270. )   zlon = zlon - 360.                                          ! zlon between  -90 and 270 
     68         IF( zlon <  90. )   WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360.   ! glam between -180 and 180 
     69         zglam(:,:) = zglam(:,:) - zlon 
     70      ELSE 
     71         zglam(:,:) = zglam(:,:) - plon 
     72      END IF 
    6473 
    65       zglam(:,:) = zglam(:,:) - zlon 
    6674      zgphi(:,:) = zgphi(:,:) - plat 
    6775      zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r6060 r6069  
    190190      ! 
    191191      !                    !==  inverse of water column thickness   ==!   (u- and v- points) 
    192       r1_hu_b(:,:) = umask_i(:,:) / ( hu_b(:,:) + 1._wp - umask_i(:,:) )    ! _i mask due to ISF 
    193       r1_hu_n(:,:) = umask_i(:,:) / ( hu_n(:,:) + 1._wp - umask_i(:,:) ) 
    194       r1_hv_b(:,:) = vmask_i(:,:) / ( hv_b(:,:) + 1._wp - vmask_i(:,:) ) 
    195       r1_hv_n(:,:) = vmask_i(:,:) / ( hv_n(:,:) + 1._wp - vmask_i(:,:) ) 
     192      r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) )    ! _i mask due to ISF 
     193      r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) 
     194      r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) ) 
     195      r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) 
    196196 
    197197      !                    !==   z_tilde coordinate case  ==!   (Restoring frequencies) 
    … …  
    418418         IF( lk_mpp )   CALL mpp_min( z_tmin )                 ! min over the global domain 
    419419         ! - ML - test: for the moment, stop simulation for too large e3_t variations 
    420          IF( ( z_tmax .GT. rn_zdef_max ) .OR. ( z_tmin .LT. - rn_zdef_max ) ) THEN 
     420         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 
    421421            IF( lk_mpp ) THEN 
    422422               CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 
    … …  
    537537      END DO 
    538538      !                                        ! Inverse of the local depth 
     539<<<<<<< .working 
    539540!!gm BUG ?  don't understand the use of umask_i here ..... 
    540       r1_hu_a(:,:) = umask_i(:,:) / ( hu_a(:,:) + 1._wp - umask_i(:,:) ) 
    541       r1_hv_a(:,:) = vmask_i(:,:) / ( hv_a(:,:) + 1._wp - vmask_i(:,:) ) 
     541      r1_hu_a(:,:) = ssumask(:,:) / ( hu_a(:,:) + 1._wp - ssumask(:,:) ) 
     542      r1_hv_a(:,:) = ssvmask(:,:) / ( hv_a(:,:) + 1._wp - ssvmask(:,:) ) 
    542543      ! 
    543544      CALL wrk_dealloc( jpi,jpj,       zht, z_scale, zwu, zwv, zhdiv ) 
    … …  
    969970      ! 
    970971      IF( ioptio /= 1 )   CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) 
    971       IF( .NOT. ln_vvl_zstar .AND. nn_isf /= 0)  CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) 
     972      IF( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) 
    972973      ! 
    973974      IF(lwp) THEN                   ! Print the choice 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r6060 r6069  
    382382      !!              - bathy : meter bathymetry (in meters) 
    383383      !!---------------------------------------------------------------------- 
    384       INTEGER  ::   ji, jj, jl, jk            ! dummy loop indices 
     384      INTEGER  ::   ji, jj, jk            ! dummy loop indices 
    385385      INTEGER  ::   inum                      ! temporary logical unit 
    386386      INTEGER  ::   ierror                    ! error flag 
    … …  
    544544               CALL iom_close( inum ) 
    545545               WHERE( bathy(:,:) <= 0._wp )  risfdep(:,:) = 0._wp 
     546 
     547               ! set grounded point to 0  
     548               ! (a treshold could be set here if needed, or set it offline based on the grounded fraction) 
     549               WHERE ( bathy(:,:) <= risfdep(:,:) + rn_isfhmin ) 
     550                  misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp 
     551                  mbathy (:,:) = 0 ; bathy  (:,:) = 0._wp 
     552               END WHERE 
    546553            END IF 
    547554            !        
    … …  
    581588      !                        
    582589      IF ( .not. ln_sco ) THEN                                !==  set a minimum depth  ==! 
    583          ! patch to avoid case bathy = ice shelf draft and bathy between 0 and zhmin 
    584          IF ( ln_isfcav ) THEN 
    585             WHERE (bathy == risfdep) 
    586                bathy   = 0.0_wp ; risfdep = 0.0_wp 
    587             END WHERE 
    588          END IF 
    589          ! end patch 
    590590         IF( rn_hmin < 0._wp ) THEN    ;   ik = - INT( rn_hmin )                                      ! from a nb of level 
    591591         ELSE                          ;   ik = MINLOC( gdepw_1d, mask = gdepw_1d > rn_hmin, dim = 1 )  ! from a depth 
    … …  
    830830   SUBROUTINE zgr_top_level 
    831831      !!---------------------------------------------------------------------- 
    832       !!                    ***  ROUTINE zgr_bot_level  *** 
     832      !!                    ***  ROUTINE zgr_top_level  *** 
    833833      !! 
    834834      !! ** Purpose :   defines the vertical index of ocean top (mik. arrays) 
    … …  
    954954      REAL(wp) ::   ze3tp , ze3wp    ! Last ocean level thickness at T- and W-points 
    955955      REAL(wp) ::   zdepwp, zdepth   ! Ajusted ocean depth to avoid too small e3t 
    956       REAL(wp) ::   zmax             ! Maximum depth 
    957956      REAL(wp) ::   zdiff            ! temporary scalar 
    958       REAL(wp) ::   zrefdep          ! temporary scalar 
     957      REAL(wp) ::   zmax             ! temporary scalar 
    959958      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zprt 
    960959      !!--------------------------------------------------------------------- 
    … …  
    986985      END DO 
    987986 
    988       IF ( ln_isfcav ) CALL zgr_isf 
    989  
    990987      ! Scale factors and depth at T- and W-points 
    991988      DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
    … …  
    995992         e3w_0  (:,:,jk) = e3w_1d  (jk) 
    996993      END DO 
     994       
     995      ! Bathy, iceshelf draft, scale factor and depth at T- and W- points in case of isf 
     996      IF ( ln_isfcav ) CALL zgr_isf 
     997 
     998      ! Scale factors and depth at T- and W-points 
     999      IF ( .NOT. ln_isfcav ) THEN 
     1000         DO jj = 1, jpj 
     1001            DO ji = 1, jpi 
     1002               ik = mbathy(ji,jj) 
     1003               IF( ik > 0 ) THEN               ! ocean point only 
     1004                  ! max ocean level case 
     1005                  IF( ik == jpkm1 ) THEN 
     1006                     zdepwp = bathy(ji,jj) 
     1007                     ze3tp  = bathy(ji,jj) - gdepw_1d(ik) 
     1008                     ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 
     1009                     e3t_0(ji,jj,ik  ) = ze3tp 
     1010                     e3t_0(ji,jj,ik+1) = ze3tp 
     1011                     e3w_0(ji,jj,ik  ) = ze3wp 
     1012                     e3w_0(ji,jj,ik+1) = ze3tp 
     1013                     gdepw_0(ji,jj,ik+1) = zdepwp 
     1014                     gdept_0(ji,jj,ik  ) = gdept_1d(ik-1) + ze3wp 
     1015                     gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 
     1016                     ! 
     1017                  ELSE                         ! standard case 
     1018                     IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN  ;   gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 
     1019                     ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
     1020                     ENDIF 
     1021   !gm Bug?  check the gdepw_1d 
     1022                     !       ... on ik 
     1023                     gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) )   & 
     1024                        &                             * ((gdept_1d(     ik  ) - gdepw_1d(ik) )   & 
     1025                        &                             / ( gdepw_1d(     ik+1) - gdepw_1d(ik) )) 
     1026                     e3t_0  (ji,jj,ik) = e3t_1d  (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
     1027                        &                             / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
     1028                     e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
     1029                        &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
     1030                     !       ... on ik+1 
     1031                     e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     1032                     e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
     1033                     gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
     1034                  ENDIF 
     1035               ENDIF 
     1036            END DO 
     1037         END DO 
     1038         ! 
     1039         it = 0 
     1040         DO jj = 1, jpj 
     1041            DO ji = 1, jpi 
     1042               ik = mbathy(ji,jj) 
     1043               IF( ik > 0 ) THEN               ! ocean point only 
     1044                  e3tp (ji,jj) = e3t_0(ji,jj,ik) 
     1045                  e3wp (ji,jj) = e3w_0(ji,jj,ik) 
     1046                  ! test 
     1047                  zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik  ) 
     1048                  IF( zdiff <= 0._wp .AND. lwp ) THEN  
     1049                     it = it + 1 
     1050                     WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj 
     1051                     WRITE(numout,*) ' bathy = ', bathy(ji,jj) 
     1052                     WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 
     1053                     WRITE(numout,*) ' e3tp    = ', e3t_0  (ji,jj,ik), ' e3wp    = ', e3w_0  (ji,jj,ik  ) 
     1054                  ENDIF 
     1055               ENDIF 
     1056            END DO 
     1057         END DO 
     1058      END IF 
     1059      ! 
     1060      ! Scale factors and depth at U-, V-, UW and VW-points 
     1061      DO jk = 1, jpk                        ! initialisation to z-scale factors 
     1062         e3u_0 (:,:,jk) = e3t_1d(jk) 
     1063         e3v_0 (:,:,jk) = e3t_1d(jk) 
     1064         e3uw_0(:,:,jk) = e3w_1d(jk) 
     1065         e3vw_0(:,:,jk) = e3w_1d(jk) 
     1066      END DO 
     1067 
     1068      DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
     1069         DO jj = 1, jpjm1 
     1070            DO ji = 1, fs_jpim1   ! vector opt. 
     1071               e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
     1072               e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
     1073               e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
     1074               e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
     1075            END DO 
     1076         END DO 
     1077      END DO 
     1078      IF ( ln_isfcav ) THEN 
     1079      ! (ISF) define e3uw (adapted for 2 cells in the water column) 
     1080         DO jj = 2, jpjm1  
     1081            DO ji = 2, fs_jpim1   ! vector opt.  
     1082               ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) 
     1083               ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) 
     1084               IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) =  MIN( gdept_0(ji,jj,ikb  ), gdept_0(ji+1,jj  ,ikb  ) ) & 
     1085                                       &            - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj  ,ikb-1) ) 
     1086               ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) 
     1087               ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) 
     1088               IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) =  MIN( gdept_0(ji,jj,ikb  ), gdept_0(ji  ,jj+1,ikb  ) ) & 
     1089                                       &            - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji  ,jj+1,ikb-1) ) 
     1090            END DO 
     1091         END DO 
     1092      END IF 
     1093 
     1094      CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
     1095      CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
     1096      ! 
     1097 
     1098      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
     1099         WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
     1100         WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
     1101         WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
     1102         WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
     1103      END DO 
     1104       
     1105      ! Scale factor at F-point 
     1106      DO jk = 1, jpk                        ! initialisation to z-scale factors 
     1107         e3f_0(:,:,jk) = e3t_1d(jk) 
     1108      END DO 
     1109      DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
     1110         DO jj = 1, jpjm1 
     1111            DO ji = 1, fs_jpim1   ! vector opt. 
     1112               e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
     1113            END DO 
     1114         END DO 
     1115      END DO 
     1116      CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
     1117      ! 
     1118      DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
     1119         WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
     1120      END DO 
     1121!!gm  bug ? :  must be a do loop with mj0,mj1 
    9971122      !  
     1123      e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
     1124      e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
     1125      e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
     1126      e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
     1127      e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
     1128 
     1129      ! Control of the sign 
     1130      IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
     1131      IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
     1132      IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
     1133      IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
     1134      
     1135      ! Compute gde3w_0 (vertical sum of e3w) 
     1136      IF ( ln_isfcav ) THEN ! if cavity 
     1137         WHERE( misfdep == 0 )   misfdep = 1 
     1138         DO jj = 1,jpj 
     1139            DO ji = 1,jpi 
     1140               gde3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 
     1141               DO jk = 2, misfdep(ji,jj) 
     1142                  gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
     1143               END DO 
     1144               IF( misfdep(ji,jj) >= 2 )   gde3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 
     1145               DO jk = misfdep(ji,jj) + 1, jpk 
     1146                  gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
     1147               END DO 
     1148            END DO 
     1149         END DO 
     1150      ELSE ! no cavity 
     1151         gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 
     1152         DO jk = 2, jpk 
     1153            gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) 
     1154         END DO 
     1155      END IF 
     1156      ! 
     1157      CALL wrk_dealloc( jpi,jpj,jpk,   zprt ) 
     1158      ! 
     1159      IF( nn_timing == 1 )  CALL timing_stop('zgr_zps') 
     1160      ! 
     1161   END SUBROUTINE zgr_zps 
     1162 
     1163 
     1164   SUBROUTINE zgr_isf 
     1165      !!---------------------------------------------------------------------- 
     1166      !!                    ***  ROUTINE zgr_isf  *** 
     1167      !!    
     1168      !! ** Purpose :   check the bathymetry in levels 
     1169      !!    
     1170      !! ** Method  :   THe water column have to contained at least 2 cells 
     1171      !!                Bathymetry and isfdraft are modified (dig/close) to respect 
     1172      !!                this criterion. 
     1173      !!    
     1174      !! ** Action  : - test compatibility between isfdraft and bathy  
     1175      !!              - bathy and isfdraft are modified 
     1176      !!---------------------------------------------------------------------- 
     1177      INTEGER  ::   ji, jj, jl, jk       ! dummy loop indices 
     1178      INTEGER  ::   ik, it               ! temporary integers 
     1179      INTEGER  ::   icompt, ibtest       ! (ISF) 
     1180      INTEGER  ::   ibtestim1, ibtestip1 ! (ISF) 
     1181      INTEGER  ::   ibtestjm1, ibtestjp1 ! (ISF) 
     1182      REAL(wp) ::   zdepth           ! Ajusted ocean depth to avoid too small e3t 
     1183      REAL(wp) ::   zmax             ! Maximum and minimum depth 
     1184      REAL(wp) ::   zbathydiff       ! isf temporary scalar 
     1185      REAL(wp) ::   zrisfdepdiff     ! isf temporary scalar 
     1186      REAL(wp) ::   ze3tp , ze3wp    ! Last ocean level thickness at T- and W-points 
     1187      REAL(wp) ::   zdepwp           ! Ajusted ocean depth to avoid too small e3t 
     1188      REAL(wp) ::   zdiff            ! temporary scalar 
     1189      REAL(wp), POINTER, DIMENSION(:,:)   ::   zrisfdep, zbathy, zmask   ! 2D workspace (ISH) 
     1190      INTEGER , POINTER, DIMENSION(:,:)   ::   zmbathy, zmisfdep         ! 2D workspace (ISH) 
     1191      !!--------------------------------------------------------------------- 
     1192      ! 
     1193      IF( nn_timing == 1 )   CALL timing_start('zgr_isf') 
     1194      ! 
     1195      CALL wrk_alloc( jpi,jpj,   zbathy, zmask, zrisfdep) 
     1196      CALL wrk_alloc( jpi,jpj,   zmisfdep, zmbathy ) 
     1197 
     1198      ! (ISF) compute misfdep 
     1199      WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) /= 0 ) ;   misfdep(:,:) = 1   ! open water : set misfdep to 1   
     1200      ELSEWHERE                      ;                         misfdep(:,:) = 2   ! iceshelf : initialize misfdep to second level  
     1201      END WHERE   
     1202 
     1203      ! Compute misfdep for ocean points (i.e. first wet level)  
     1204      ! find the first ocean level such that the first level thickness  
     1205      ! is larger than the bot_level of e3zps_min and e3zps_rat * e3t_0 (where  
     1206      ! e3t_0 is the reference level thickness  
     1207      DO jk = 2, jpkm1  
     1208         zdepth = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat )  
     1209         WHERE( 0._wp < risfdep(:,:) .AND. risfdep(:,:) >= zdepth )   misfdep(:,:) = jk+1  
     1210      END DO  
     1211      WHERE ( 0._wp < risfdep(:,:) .AND. risfdep(:,:) <= e3t_1d(1) ) 
     1212         risfdep(:,:) = 0. ; misfdep(:,:) = 1 
     1213      END WHERE 
     1214 
     1215      ! remove very shallow ice shelf (less than ~ 10m if 75L) 
     1216      WHERE (risfdep(:,:) <= 10._wp .AND. misfdep(:,:) > 1) 
     1217         misfdep = 0; risfdep = 0.0_wp; 
     1218         mbathy  = 0; bathy   = 0.0_wp; 
     1219      END WHERE 
     1220      WHERE (bathy(:,:) <= 30.0_wp .AND. gphit < -60._wp) 
     1221         misfdep = 0; risfdep = 0.0_wp; 
     1222         mbathy  = 0; bathy   = 0.0_wp; 
     1223      END WHERE 
     1224  
     1225! basic check for the compatibility of bathy and risfdep. I think it should be offline because it is not perfect and cannot solved all the situation 
     1226      icompt = 0  
     1227! run the bathy check 10 times to be sure all the modif in the bathy or iceshelf draft are compatible together 
     1228      DO jl = 1, 10      
     1229         ! check at each iteration if isf is grounded or not (1cm treshold have to be update after first coupling experiments) 
     1230         WHERE (bathy(:,:) <= risfdep(:,:) + rn_isfhmin) 
     1231            misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp 
     1232            mbathy (:,:) = 0 ; bathy  (:,:) = 0._wp 
     1233         END WHERE 
     1234         WHERE (mbathy(:,:) <= 0)  
     1235            misfdep(:,:) = 0; risfdep(:,:) = 0._wp  
     1236            mbathy (:,:) = 0; bathy  (:,:) = 0._wp 
     1237         END WHERE 
     1238         IF( lk_mpp ) THEN 
     1239            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1240            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1241            misfdep(:,:) = INT( zbathy(:,:) ) 
     1242 
     1243            CALL lbc_lnk( risfdep,'T', 1. ) 
     1244            CALL lbc_lnk( bathy,  'T', 1. ) 
     1245 
     1246            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1247            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1248            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1249         ENDIF 
     1250         IF( nperio == 1 .OR. nperio  ==  4 .OR. nperio  ==  6 ) THEN  
     1251            misfdep( 1 ,:) = misfdep(jpim1,:)            ! local domain is cyclic east-west  
     1252            misfdep(jpi,:) = misfdep(  2  ,:)  
     1253            mbathy( 1 ,:)  = mbathy(jpim1,:)             ! local domain is cyclic east-west 
     1254            mbathy(jpi,:)  = mbathy(  2  ,:) 
     1255         ENDIF 
     1256 
     1257         ! split last cell if possible (only where water column is 2 cell or less) 
     1258         ! if coupled to ice sheet, we do not modify the bathymetry (can be discuss). 
     1259         IF ( .NOT. ln_iscpl) THEN 
     1260            DO jk = jpkm1, 1, -1 
     1261               zmax = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
     1262               WHERE( gdepw_1d(jk) < bathy(:,:) .AND. bathy(:,:) <= zmax .AND. misfdep + 1 >= mbathy) 
     1263                  mbathy(:,:) = jk 
     1264                  bathy(:,:)  = zmax 
     1265               END WHERE 
     1266            END DO 
     1267         END IF 
     1268  
     1269         ! split top cell if possible (only where water column is 2 cell or less) 
     1270         DO jk = 2, jpkm1 
     1271            zmax = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
     1272            WHERE( gdepw_1d(jk+1) > risfdep(:,:) .AND. risfdep(:,:) >= zmax .AND. misfdep + 1 >= mbathy) 
     1273               misfdep(:,:) = jk 
     1274               risfdep(:,:) = zmax 
     1275            END WHERE 
     1276         END DO 
     1277 
     1278  
     1279 ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition 
     1280         DO jj = 1, jpj 
     1281            DO ji = 1, jpi 
     1282               ! find the minimum change option: 
     1283               ! test bathy 
     1284               IF (risfdep(ji,jj) > 1) THEN 
     1285                  IF ( .NOT. ln_iscpl ) THEN 
     1286                     zbathydiff  =ABS(bathy(ji,jj)   - (gdepw_1d(mbathy (ji,jj)+1) & 
     1287                         &            + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 
     1288                     zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj)  ) & 
     1289                         &            - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 
     1290                     IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) <  misfdep(ji,jj)) THEN 
     1291                        IF (zbathydiff <= zrisfdepdiff) THEN 
     1292                           bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj)+1)*e3zps_rat ) 
     1293                           mbathy(ji,jj)= mbathy(ji,jj) + 1 
     1294                        ELSE 
     1295                           risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 
     1296                           misfdep(ji,jj) = misfdep(ji,jj) - 1 
     1297                        END IF 
     1298                     ENDIF 
     1299                  ELSE 
     1300                     IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) <  misfdep(ji,jj)) THEN 
     1301                        risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 
     1302                        misfdep(ji,jj) = misfdep(ji,jj) - 1 
     1303                     END IF 
     1304                  END IF 
     1305               END IF 
     1306            END DO 
     1307         END DO 
     1308  
     1309         ! At least 2 levels for water thickness at T, U, and V point. 
     1310         DO jj = 1, jpj 
     1311            DO ji = 1, jpi 
     1312               ! find the minimum change option: 
     1313               ! test bathy 
     1314               IF( misfdep(ji,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN 
     1315                  IF ( .NOT. ln_iscpl ) THEN  
     1316                     zbathydiff  =ABS(bathy(ji,jj)   - ( gdepw_1d(mbathy (ji,jj)+1) & 
     1317                         &                             + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 
     1318                     zrisfdepdiff=ABS(risfdep(ji,jj) - ( gdepw_1d(misfdep(ji,jj)  ) &  
     1319                         &                             - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 
     1320                     IF (zbathydiff <= zrisfdepdiff) THEN 
     1321                        mbathy(ji,jj) = mbathy(ji,jj) + 1 
     1322                        bathy(ji,jj)  = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 
     1323                     ELSE 
     1324                        misfdep(ji,jj)= misfdep(ji,jj) - 1 
     1325                        risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 
     1326                     END IF 
     1327                  ELSE 
     1328                     misfdep(ji,jj)= misfdep(ji,jj) - 1 
     1329                     risfdep(ji,jj)= gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 
     1330                  END IF 
     1331               ENDIF 
     1332            END DO 
     1333         END DO 
     1334  
     1335 ! point V mbathy(ji,jj) == misfdep(ji,jj+1)  
     1336         DO jj = 1, jpjm1 
     1337            DO ji = 1, jpim1 
     1338               IF( misfdep(ji,jj+1) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN 
     1339                  IF ( .NOT. ln_iscpl ) THEN  
     1340                     zbathydiff  =ABS(bathy(ji,jj    ) - ( gdepw_1d(mbathy (ji,jj)+1) & 
     1341                          &                              + MIN( e3zps_min, e3t_1d(mbathy (ji,jj  )+1)*e3zps_rat ))) 
     1342                     zrisfdepdiff=ABS(risfdep(ji,jj+1) - ( gdepw_1d(misfdep(ji,jj+1)) & 
     1343                          &                              - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 
     1344                     IF (zbathydiff <= zrisfdepdiff) THEN 
     1345                        mbathy(ji,jj) = mbathy(ji,jj) + 1 
     1346                        bathy(ji,jj)  = gdepw_1d(mbathy (ji,jj  )) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj   )+1)*e3zps_rat ) 
     1347                     ELSE 
     1348                        misfdep(ji,jj+1)  = misfdep(ji,jj+1) - 1 
     1349                        risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 
     1350                     END IF 
     1351                  ELSE 
     1352                     misfdep(ji,jj+1)  = misfdep(ji,jj+1) - 1 
     1353                     risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 
     1354                  END IF 
     1355               ENDIF 
     1356            END DO 
     1357         END DO 
     1358  
     1359         IF( lk_mpp ) THEN 
     1360            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1361            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1362            misfdep(:,:) = INT( zbathy(:,:) ) 
     1363 
     1364            CALL lbc_lnk( risfdep,'T', 1. ) 
     1365            CALL lbc_lnk( bathy,  'T', 1. ) 
     1366 
     1367            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1368            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1369            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1370         ENDIF 
     1371 ! point V misdep(ji,jj) == mbathy(ji,jj+1)  
     1372         DO jj = 1, jpjm1 
     1373            DO ji = 1, jpim1 
     1374               IF( misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) > 1) THEN 
     1375                  IF ( .NOT. ln_iscpl ) THEN  
     1376                     zbathydiff  =ABS(  bathy(ji,jj+1) - ( gdepw_1d(mbathy (ji,jj+1)+1) & 
     1377                           &                             + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 
     1378                     zrisfdepdiff=ABS(risfdep(ji,jj  ) - ( gdepw_1d(misfdep(ji,jj  )  ) & 
     1379                           &                             - MIN( e3zps_min, e3t_1d(misfdep(ji,jj  )-1)*e3zps_rat ))) 
     1380                     IF (zbathydiff <= zrisfdepdiff) THEN 
     1381                        mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 
     1382                        bathy  (ji,jj+1) = gdepw_1d(mbathy (ji,jj+1)  ) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ) 
     1383                     ELSE 
     1384                        misfdep(ji,jj)   = misfdep(ji,jj) - 1 
     1385                        risfdep(ji,jj)   = gdepw_1d(misfdep(ji,jj  )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj  )  )*e3zps_rat ) 
     1386                     END IF 
     1387                  ELSE 
     1388                     misfdep(ji,jj)   = misfdep(ji,jj) - 1 
     1389                     risfdep(ji,jj)   = gdepw_1d(misfdep(ji,jj  )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj  )  )*e3zps_rat ) 
     1390                  END IF 
     1391               ENDIF 
     1392            END DO 
     1393         END DO 
     1394  
     1395  
     1396         IF( lk_mpp ) THEN  
     1397            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1398            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1399            misfdep(:,:) = INT( zbathy(:,:) ) 
     1400 
     1401            CALL lbc_lnk( risfdep,'T', 1. ) 
     1402            CALL lbc_lnk( bathy,  'T', 1. ) 
     1403 
     1404            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1405            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1406            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1407         ENDIF  
     1408  
     1409 ! point U mbathy(ji,jj) == misfdep(ji,jj+1)  
     1410         DO jj = 1, jpjm1 
     1411            DO ji = 1, jpim1 
     1412               IF( misfdep(ji+1,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN 
     1413                  IF ( .NOT. ln_iscpl ) THEN  
     1414                  zbathydiff  =ABS(  bathy(ji  ,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & 
     1415                       &                              + MIN( e3zps_min, e3t_1d(mbathy (ji  ,jj)+1)*e3zps_rat ))) 
     1416                  zrisfdepdiff=ABS(risfdep(ji+1,jj) - ( gdepw_1d(misfdep(ji+1,jj)) & 
     1417                       &                              - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 
     1418                  IF (zbathydiff <= zrisfdepdiff) THEN 
     1419                     mbathy(ji,jj) = mbathy(ji,jj) + 1 
     1420                     bathy(ji,jj)  = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 
     1421                  ELSE 
     1422                     misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 
     1423                     risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 
     1424                  END IF 
     1425                  ELSE 
     1426                     misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 
     1427                     risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 
     1428                  ENDIF 
     1429               ENDIF 
     1430            ENDDO 
     1431         ENDDO 
     1432  
     1433         IF( lk_mpp ) THEN  
     1434            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1435            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1436            misfdep(:,:) = INT( zbathy(:,:) ) 
     1437 
     1438            CALL lbc_lnk( risfdep,'T', 1. ) 
     1439            CALL lbc_lnk( bathy,  'T', 1. ) 
     1440 
     1441            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1442            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1443            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1444         ENDIF  
     1445  
     1446 ! point U misfdep(ji,jj) == bathy(ji,jj+1)  
     1447         DO jj = 1, jpjm1 
     1448            DO ji = 1, jpim1 
     1449               IF( misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) > 1) THEN 
     1450                  IF ( .NOT. ln_iscpl ) THEN  
     1451                     zbathydiff  =ABS(  bathy(ji+1,jj) - ( gdepw_1d(mbathy (ji+1,jj)+1) & 
     1452                          &                              + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 
     1453                     zrisfdepdiff=ABS(risfdep(ji  ,jj) - ( gdepw_1d(misfdep(ji  ,jj)  ) & 
     1454                          &                              - MIN( e3zps_min, e3t_1d(misfdep(ji  ,jj)-1)*e3zps_rat ))) 
     1455                     IF (zbathydiff <= zrisfdepdiff) THEN 
     1456                        mbathy(ji+1,jj)  = mbathy (ji+1,jj) + 1 
     1457                        bathy (ji+1,jj)  = gdepw_1d(mbathy (ji+1,jj)  ) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 
     1458                     ELSE 
     1459                        misfdep(ji,jj)   = misfdep(ji  ,jj) - 1 
     1460                        risfdep(ji,jj)   = gdepw_1d(misfdep(ji  ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji  ,jj)   )*e3zps_rat ) 
     1461                     END IF 
     1462                  ELSE 
     1463                     misfdep(ji,jj)   = misfdep(ji  ,jj) - 1 
     1464                     risfdep(ji,jj)   = gdepw_1d(misfdep(ji  ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji  ,jj)   )*e3zps_rat ) 
     1465                  ENDIF 
     1466               ENDIF 
     1467            ENDDO 
     1468         ENDDO 
     1469  
     1470         IF( lk_mpp ) THEN 
     1471            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1472            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1473            misfdep(:,:) = INT( zbathy(:,:) ) 
     1474 
     1475            CALL lbc_lnk( risfdep,'T', 1. ) 
     1476            CALL lbc_lnk( bathy,  'T', 1. ) 
     1477 
     1478            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1479            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1480            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1481         ENDIF 
     1482      END DO 
     1483      ! end dig bathy/ice shelf to be compatible 
     1484      ! now fill single point in "coastline" of ice shelf, bathy, hole, and test again one cell tickness 
     1485      DO jl = 1,20 
     1486  
     1487 ! remove single point "bay" on isf coast line in the ice shelf draft' 
     1488         DO jk = 2, jpk 
     1489            WHERE (misfdep==0) misfdep=jpk 
     1490            zmask=0._wp 
     1491            WHERE (misfdep <= jk) zmask=1 
     1492            DO jj = 2, jpjm1 
     1493               DO ji = 2, jpim1 
     1494                  IF (misfdep(ji,jj) == jk) THEN 
     1495                     ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) 
     1496                     IF (ibtest <= 1) THEN 
     1497                        risfdep(ji,jj)=gdepw_1d(jk+1) ; misfdep(ji,jj)=jk+1 
     1498                        IF (misfdep(ji,jj) > mbathy(ji,jj)) misfdep(ji,jj) = jpk 
     1499                     END IF 
     1500                  END IF 
     1501               END DO 
     1502            END DO 
     1503         END DO 
     1504         WHERE (misfdep==jpk) 
     1505             misfdep=0 ; risfdep=0._wp ; mbathy=0 ; bathy=0._wp 
     1506         END WHERE 
     1507         IF( lk_mpp ) THEN 
     1508            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1509            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1510            misfdep(:,:) = INT( zbathy(:,:) ) 
     1511 
     1512            CALL lbc_lnk( risfdep,'T', 1. ) 
     1513            CALL lbc_lnk( bathy,  'T', 1. ) 
     1514 
     1515            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1516            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1517            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1518         ENDIF 
     1519  
     1520 ! remove single point "bay" on bathy coast line beneath an ice shelf' 
     1521         DO jk = jpk,1,-1 
     1522            zmask=0._wp 
     1523            WHERE (mbathy >= jk ) zmask=1 
     1524            DO jj = 2, jpjm1 
     1525               DO ji = 2, jpim1 
     1526                  IF (mbathy(ji,jj) == jk .AND. misfdep(ji,jj) >= 2) THEN 
     1527                     ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) 
     1528                     IF (ibtest <= 1) THEN 
     1529                        bathy(ji,jj)=gdepw_1d(jk) ; mbathy(ji,jj)=jk-1 
     1530                        IF (misfdep(ji,jj) > mbathy(ji,jj)) mbathy(ji,jj) = 0 
     1531                     END IF 
     1532                  END IF 
     1533               END DO 
     1534            END DO 
     1535         END DO 
     1536         WHERE (mbathy==0) 
     1537             misfdep=0 ; risfdep=0._wp ; mbathy=0 ; bathy=0._wp 
     1538         END WHERE 
     1539         IF( lk_mpp ) THEN 
     1540            zbathy(:,:)  = FLOAT( misfdep(:,:) ) 
     1541            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1542            misfdep(:,:) = INT( zbathy(:,:) ) 
     1543 
     1544            CALL lbc_lnk( risfdep,'T', 1. ) 
     1545            CALL lbc_lnk( bathy,  'T', 1. ) 
     1546 
     1547            zbathy(:,:)  = FLOAT( mbathy(:,:) ) 
     1548            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1549            mbathy(:,:)  = INT( zbathy(:,:) ) 
     1550         ENDIF 
     1551  
     1552 ! fill hole in ice shelf 
     1553         zmisfdep = misfdep 
     1554         zrisfdep = risfdep 
     1555         WHERE (zmisfdep <= 1._wp) zmisfdep=jpk 
     1556         DO jj = 2, jpjm1 
     1557            DO ji = 2, jpim1 
     1558               ibtestim1 = zmisfdep(ji-1,jj  ) ; ibtestip1 = zmisfdep(ji+1,jj  ) 
     1559               ibtestjm1 = zmisfdep(ji  ,jj-1) ; ibtestjp1 = zmisfdep(ji  ,jj+1) 
     1560               IF( zmisfdep(ji,jj) >= mbathy(ji-1,jj  ) ) ibtestim1 = jpk 
     1561               IF( zmisfdep(ji,jj) >= mbathy(ji+1,jj  ) ) ibtestip1 = jpk 
     1562               IF( zmisfdep(ji,jj) >= mbathy(ji  ,jj-1) ) ibtestjm1 = jpk 
     1563               IF( zmisfdep(ji,jj) >= mbathy(ji  ,jj+1) ) ibtestjp1 = jpk 
     1564               ibtest=MIN(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 
     1565               IF( ibtest == jpk .AND. misfdep(ji,jj) >= 2) THEN 
     1566                  mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp 
     1567               END IF 
     1568               IF( zmisfdep(ji,jj) < ibtest .AND. misfdep(ji,jj) >= 2) THEN 
     1569                  misfdep(ji,jj) = ibtest 
     1570                  risfdep(ji,jj) = gdepw_1d(ibtest) 
     1571               ENDIF 
     1572            ENDDO 
     1573         ENDDO 
     1574  
     1575         IF( lk_mpp ) THEN  
     1576            zbathy(:,:)  = FLOAT( misfdep(:,:) )  
     1577            CALL lbc_lnk( zbathy,  'T', 1. )  
     1578            misfdep(:,:) = INT( zbathy(:,:) )  
     1579 
     1580            CALL lbc_lnk( risfdep, 'T', 1. )  
     1581            CALL lbc_lnk( bathy,   'T', 1. ) 
     1582 
     1583            zbathy(:,:) = FLOAT( mbathy(:,:) ) 
     1584            CALL lbc_lnk( zbathy,  'T', 1. ) 
     1585            mbathy(:,:) = INT( zbathy(:,:) ) 
     1586         ENDIF  
     1587 ! 
     1588 !! fill hole in bathymetry 
     1589         zmbathy (:,:)=mbathy (:,:) 
     1590         DO jj = 2, jpjm1 
     1591            DO ji = 2, jpim1 
     1592               ibtestim1 = zmbathy(ji-1,jj  ) ; ibtestip1 = zmbathy(ji+1,jj  ) 
     1593               ibtestjm1 = zmbathy(ji  ,jj-1) ; ibtestjp1 = zmbathy(ji  ,jj+1) 
     1594               IF( zmbathy(ji,jj) <  misfdep(ji-1,jj  ) ) ibtestim1 = 0 
     1595               IF( zmbathy(ji,jj) <  misfdep(ji+1,jj  ) ) ibtestip1 = 0 
     1596               IF( zmbathy(ji,jj) <  misfdep(ji  ,jj-1) ) ibtestjm1 = 0 
     1597               IF( zmbathy(ji,jj) <  misfdep(ji  ,jj+1) ) ibtestjp1 = 0 
     1598               ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 
     1599               IF( ibtest == 0 .AND. misfdep(ji,jj) >= 2) THEN 
     1600                  mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; 
     1601               END IF 
     1602               IF( ibtest < zmbathy(ji,jj) .AND. misfdep(ji,jj) >= 2) THEN 
     1603                  mbathy(ji,jj) = ibtest 
     1604                  bathy(ji,jj)  = gdepw_1d(ibtest+1)  
     1605               ENDIF 
     1606            END DO 
     1607         END DO 
     1608         IF( lk_mpp ) THEN  
     1609            zbathy(:,:)  = FLOAT( misfdep(:,:) )  
     1610            CALL lbc_lnk( zbathy,  'T', 1. )  
     1611            misfdep(:,:) = INT( zbathy(:,:) )  
     1612 
     1613            CALL lbc_lnk( risfdep, 'T', 1. )  
     1614            CALL lbc_lnk( bathy,   'T', 1. ) 
     1615 
     1616            zbathy(:,:) = FLOAT( mbathy(:,:) ) 
     1617            CALL lbc_lnk( zbathy,  'T', 1. ) 
     1618            mbathy(:,:) = INT( zbathy(:,:) ) 
     1619         ENDIF  
     1620 ! if not compatible after all check (ie U point water column less than 2 cells), mask U 
     1621         DO jj = 1, jpjm1 
     1622            DO ji = 1, jpim1 
     1623               IF (mbathy(ji,jj) == misfdep(ji+1,jj) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji+1,jj) >= 1) THEN 
     1624                  mbathy(ji,jj)  = mbathy(ji,jj) - 1 ; bathy(ji,jj)   = gdepw_1d(mbathy(ji,jj)+1) ; 
     1625               END IF 
     1626            END DO 
     1627         END DO 
     1628         IF( lk_mpp ) THEN  
     1629            zbathy(:,:)  = FLOAT( misfdep(:,:) )  
     1630            CALL lbc_lnk( zbathy,  'T', 1. )  
     1631            misfdep(:,:) = INT( zbathy(:,:) )  
     1632 
     1633            CALL lbc_lnk( risfdep, 'T', 1. )  
     1634            CALL lbc_lnk( bathy,   'T', 1. ) 
     1635 
     1636            zbathy(:,:) = FLOAT( mbathy(:,:) ) 
     1637            CALL lbc_lnk( zbathy,  'T', 1. ) 
     1638            mbathy(:,:) = INT( zbathy(:,:) ) 
     1639         ENDIF  
     1640 ! if not compatible after all check (ie U point water column less than 2 cells), mask U 
     1641         DO jj = 1, jpjm1 
     1642            DO ji = 1, jpim1 
     1643               IF (misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji+1,jj) >= 1) THEN 
     1644                  mbathy(ji+1,jj)  = mbathy(ji+1,jj) - 1;   bathy(ji+1,jj)   = gdepw_1d(mbathy(ji+1,jj)+1) ; 
     1645               END IF 
     1646            END DO 
     1647         END DO 
     1648         IF( lk_mpp ) THEN  
     1649            zbathy(:,:)  = FLOAT( misfdep(:,:) )  
     1650            CALL lbc_lnk( zbathy, 'T', 1. )  
     1651            misfdep(:,:) = INT( zbathy(:,:) )  
     1652 
     1653            CALL lbc_lnk( risfdep,'T', 1. )  
     1654            CALL lbc_lnk( bathy,  'T', 1. ) 
     1655 
     1656            zbathy(:,:) = FLOAT( mbathy(:,:) ) 
     1657            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1658            mbathy(:,:) = INT( zbathy(:,:) ) 
     1659         ENDIF  
     1660 ! if not compatible after all check (ie V point water column less than 2 cells), mask V 
     1661         DO jj = 1, jpjm1 
     1662            DO ji = 1, jpi 
     1663               IF (mbathy(ji,jj) == misfdep(ji,jj+1) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji,jj+1) >= 1) THEN 
     1664                  mbathy(ji,jj)  = mbathy(ji,jj) - 1 ; bathy(ji,jj)   = gdepw_1d(mbathy(ji,jj)+1) ; 
     1665               END IF 
     1666            END DO 
     1667         END DO 
     1668         IF( lk_mpp ) THEN  
     1669            zbathy(:,:)  = FLOAT( misfdep(:,:) )  
     1670            CALL lbc_lnk( zbathy, 'T', 1. )  
     1671            misfdep(:,:) = INT( zbathy(:,:) )  
     1672 
     1673            CALL lbc_lnk( risfdep,'T', 1. )  
     1674            CALL lbc_lnk( bathy,  'T', 1. ) 
     1675 
     1676            zbathy(:,:) = FLOAT( mbathy(:,:) ) 
     1677            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1678            mbathy(:,:) = INT( zbathy(:,:) ) 
     1679         ENDIF  
     1680 ! if not compatible after all check (ie V point water column less than 2 cells), mask V 
     1681         DO jj = 1, jpjm1 
     1682            DO ji = 1, jpi 
     1683               IF (misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji,jj+1) >= 1) THEN 
     1684                  mbathy(ji,jj+1)  = mbathy(ji,jj+1) - 1 ; bathy(ji,jj+1) = gdepw_1d(mbathy(ji,jj+1)+1) ; 
     1685               END IF 
     1686            END DO 
     1687         END DO 
     1688         IF( lk_mpp ) THEN  
     1689            zbathy(:,:)  = FLOAT( misfdep(:,:) )  
     1690            CALL lbc_lnk( zbathy, 'T', 1. )  
     1691            misfdep(:,:) = INT( zbathy(:,:) )  
     1692 
     1693            CALL lbc_lnk( risfdep,'T', 1. )  
     1694            CALL lbc_lnk( bathy,  'T', 1. ) 
     1695 
     1696            zbathy(:,:) = FLOAT( mbathy(:,:) ) 
     1697            CALL lbc_lnk( zbathy, 'T', 1. ) 
     1698            mbathy(:,:) = INT( zbathy(:,:) ) 
     1699         ENDIF  
     1700 ! if not compatible after all check, mask T 
     1701         DO jj = 1, jpj 
     1702            DO ji = 1, jpi 
     1703               IF (mbathy(ji,jj) <= misfdep(ji,jj)) THEN 
     1704                  misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0._wp ; mbathy(ji,jj)  = 0 ; bathy(ji,jj)   = 0._wp ; 
     1705               END IF 
     1706            END DO 
     1707         END DO 
     1708  
     1709         WHERE (mbathy(:,:) == 1) 
     1710            mbathy = 0; bathy = 0.0_wp ; misfdep = 0 ; risfdep = 0.0_wp 
     1711         END WHERE 
     1712      END DO  
     1713! end check compatibility ice shelf/bathy 
     1714      ! remove very shallow ice shelf (less than ~ 10m if 75L) 
     1715      WHERE (risfdep(:,:) <= 10._wp) 
     1716         misfdep = 1; risfdep = 0.0_wp; 
     1717      END WHERE 
     1718 
     1719      IF( icompt == 0 ) THEN  
     1720         IF(lwp) WRITE(numout,*)'     no points with ice shelf too close to bathymetry'  
     1721      ELSE  
     1722         IF(lwp) WRITE(numout,*)'    ',icompt,' ocean grid points with ice shelf thickness reduced to avoid bathymetry'  
     1723      ENDIF  
     1724 
     1725      ! compute scale factor and depth at T- and W- points 
    9981726      DO jj = 1, jpj 
    9991727         DO ji = 1, jpi 
    … …  
    10171745                  ELSE                                       ;   gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
    10181746                  ENDIF 
     1747      !            gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 
    10191748!gm Bug?  check the gdepw_1d 
    10201749                  !       ... on ik 
    … …  
    10221751                     &                             * ((gdept_1d(     ik  ) - gdepw_1d(ik) )   & 
    10231752                     &                             / ( gdepw_1d(     ik+1) - gdepw_1d(ik) )) 
    1024                   e3t_0  (ji,jj,ik) = e3t_1d  (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) )   &  
    1025                      &                             / ( gdepw_1d(      ik+1) - gdepw_1d(ik) )  
    1026                   e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) )   & 
    1027                      &                     * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 
     1753                  e3t_0  (ji,jj,ik  ) = gdepw_0(ji,jj,ik+1) - gdepw_1d(ik  ) 
     1754                  e3w_0  (ji,jj,ik  ) = gdept_0(ji,jj,ik  ) - gdept_1d(ik-1) 
    10281755                  !       ... on ik+1 
    10291756                  e3w_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
    10301757                  e3t_0  (ji,jj,ik+1) = e3t_0  (ji,jj,ik) 
    1031                   gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 
    10321758               ENDIF 
    10331759            ENDIF 
    … …  
    10551781      END DO 
    10561782      ! 
    1057       IF ( ln_isfcav ) THEN 
    10581783      ! (ISF) Definition of e3t, u, v, w for ISF case 
    1059          DO jj = 1, jpj  
    1060             DO ji = 1, jpi  
    1061                ik = misfdep(ji,jj)  
    1062                IF( ik > 1 ) THEN               ! ice shelf point only  
    1063                   IF( risfdep(ji,jj) < gdepw_1d(ik) )  risfdep(ji,jj)= gdepw_1d(ik)  
    1064                   gdepw_0(ji,jj,ik) = risfdep(ji,jj)  
     1784      DO jj = 1, jpj  
     1785         DO ji = 1, jpi  
     1786            ik = misfdep(ji,jj)  
     1787            IF( ik > 1 ) THEN               ! ice shelf point only  
     1788               IF( risfdep(ji,jj) < gdepw_1d(ik) )  risfdep(ji,jj)= gdepw_1d(ik)  
     1789               gdepw_0(ji,jj,ik) = risfdep(ji,jj)  
    10651790!gm Bug?  check the gdepw_0  
    1066                !       ... on ik  
    1067                   gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) )   &  
    1068                      &                               * ( gdepw_1d(ik+1) - gdept_1d(ik)      )   &  
    1069                      &                               / ( gdepw_1d(ik+1) - gdepw_1d(ik)      )  
    1070                   e3t_0  (ji,jj,ik  ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)  
    1071                   e3w_0  (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 
    1072  
    1073                   IF( ik + 1 == mbathy(ji,jj) ) THEN               ! ice shelf point only (2 cell water column)  
    1074                      e3w_0  (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)  
    1075                   ENDIF  
    1076                !       ... on ik / ik-1  
    1077                   e3w_0  (ji,jj,ik  ) = 2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))  
    1078                   e3t_0  (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 
     1791            !       ... on ik  
     1792               gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) )   &  
     1793                  &                               * ( gdepw_1d(ik+1) - gdept_1d(ik)      )   &  
     1794                  &                               / ( gdepw_1d(ik+1) - gdepw_1d(ik)      )  
     1795               e3t_0  (ji,jj,ik  ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik)  
     1796               e3w_0  (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 
     1797 
     1798               IF( ik + 1 == mbathy(ji,jj) ) THEN               ! ice shelf point only (2 cell water column)  
     1799                  e3w_0  (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik)  
     1800               ENDIF  
     1801            !       ... on ik / ik-1  
     1802               e3w_0  (ji,jj,ik  ) = e3t_0  (ji,jj,ik) !2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik))  
     1803               e3t_0  (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 
    10791804! The next line isn't required and doesn't affect results - included for consistency with bathymetry code  
    1080                   gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 
     1805               gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 
     1806            ENDIF  
     1807         END DO  
     1808      END DO  
     1809    
     1810      it = 0  
     1811      DO jj = 1, jpj  
     1812         DO ji = 1, jpi  
     1813            ik = misfdep(ji,jj)  
     1814            IF( ik > 1 ) THEN               ! ice shelf point only  
     1815               e3tp (ji,jj) = e3t_0(ji,jj,ik  )  
     1816               e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )  
     1817            ! test  
     1818               zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik  )  
     1819               IF( zdiff <= 0. .AND. lwp ) THEN   
     1820                  it = it + 1  
     1821                  WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj  
     1822                  WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)  
     1823                  WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff  
     1824                  WRITE(numout,*) ' e3tp  = ', e3tp(ji,jj), ' e3wp  = ', e3wp(ji,jj)  
    10811825               ENDIF  
    1082             END DO  
     1826            ENDIF  
    10831827         END DO  
    1084       !  
    1085          it = 0  
    1086          DO jj = 1, jpj  
    1087             DO ji = 1, jpi  
    1088                ik = misfdep(ji,jj)  
    1089                IF( ik > 1 ) THEN               ! ice shelf point only  
    1090                   e3tp (ji,jj) = e3t_0(ji,jj,ik  )  
    1091                   e3wp (ji,jj) = e3w_0(ji,jj,ik+1 )  
    1092                ! test  
    1093                   zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik  )  
    1094                   IF( zdiff <= 0. .AND. lwp ) THEN   
    1095                      it = it + 1  
    1096                      WRITE(numout,*) ' it      = ', it, ' ik      = ', ik, ' (i,j) = ', ji, jj  
    1097                      WRITE(numout,*) ' risfdep = ', risfdep(ji,jj)  
    1098                      WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff  
    1099                      WRITE(numout,*) ' e3tp  = ', e3tp(ji,jj), ' e3wp  = ', e3wp(ji,jj)  
    1100                   ENDIF  
    1101                ENDIF  
    1102             END DO  
    1103          END DO  
    1104       END IF 
    1105       ! END (ISF) 
    1106  
    1107       ! Scale factors and depth at U-, V-, UW and VW-points 
    1108       DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1109          e3u_0 (:,:,jk) = e3t_1d(jk) 
    1110          e3v_0 (:,:,jk) = e3t_1d(jk) 
    1111          e3uw_0(:,:,jk) = e3w_1d(jk) 
    1112          e3vw_0(:,:,jk) = e3w_1d(jk) 
    1113       END DO 
    1114       DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
    1115          DO jj = 1, jpjm1 
    1116             DO ji = 1, fs_jpim1   ! vector opt. 
    1117                e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 
    1118                e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 
    1119                e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 
    1120                e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 
    1121             END DO 
    1122          END DO 
    1123       END DO 
    1124       IF ( ln_isfcav ) THEN 
    1125       ! (ISF) define e3uw (adapted for 2 cells in the water column) 
    1126          DO jj = 2, jpjm1  
    1127             DO ji = 2, fs_jpim1   ! vector opt.  
    1128                ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) 
    1129                ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) 
    1130                IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) =  MIN( gdept_0(ji,jj,ikb  ), gdept_0(ji+1,jj  ,ikb  ) ) & 
    1131                                        &            - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj  ,ikb-1) ) 
    1132                ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) 
    1133                ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) 
    1134                IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) =  MIN( gdept_0(ji,jj,ikb  ), gdept_0(ji  ,jj+1,ikb  ) ) & 
    1135                                        &            - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji  ,jj+1,ikb-1) ) 
    1136             END DO 
    1137          END DO 
    1138       END IF 
    1139  
    1140       CALL lbc_lnk( e3u_0 , 'U', 1._wp )   ;   CALL lbc_lnk( e3uw_0, 'U', 1._wp )   ! lateral boundary conditions 
    1141       CALL lbc_lnk( e3v_0 , 'V', 1._wp )   ;   CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 
    1142       ! 
    1143       DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1144          WHERE( e3u_0 (:,:,jk) == 0._wp )   e3u_0 (:,:,jk) = e3t_1d(jk) 
    1145          WHERE( e3v_0 (:,:,jk) == 0._wp )   e3v_0 (:,:,jk) = e3t_1d(jk) 
    1146          WHERE( e3uw_0(:,:,jk) == 0._wp )   e3uw_0(:,:,jk) = e3w_1d(jk) 
    1147          WHERE( e3vw_0(:,:,jk) == 0._wp )   e3vw_0(:,:,jk) = e3w_1d(jk) 
    1148       END DO 
    1149        
    1150       ! Scale factor at F-point 
    1151       DO jk = 1, jpk                        ! initialisation to z-scale factors 
    1152          e3f_0(:,:,jk) = e3t_1d(jk) 
    1153       END DO 
    1154       DO jk = 1, jpk                        ! Computed as the minimum of neighbooring V-scale factors 
    1155          DO jj = 1, jpjm1 
    1156             DO ji = 1, fs_jpim1   ! vector opt. 
    1157                e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 
    1158             END DO 
    1159          END DO 
    1160       END DO 
    1161       CALL lbc_lnk( e3f_0, 'F', 1._wp )       ! Lateral boundary conditions 
    1162       ! 
    1163       DO jk = 1, jpk                        ! set to z-scale factor if zero (i.e. along closed boundaries) 
    1164          WHERE( e3f_0(:,:,jk) == 0._wp )   e3f_0(:,:,jk) = e3t_1d(jk) 
    1165       END DO 
    1166 !!gm  bug ? :  must be a do loop with mj0,mj1 
    1167       !  
    1168       e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:)     ! we duplicate factor scales for jj = 1 and jj = 2 
    1169       e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:)  
    1170       e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:)  
    1171       e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:)  
    1172       e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:)  
    1173  
    1174       ! Control of the sign 
    1175       IF( MINVAL( e3t_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3t_0 <= 0' ) 
    1176       IF( MINVAL( e3w_0  (:,:,:) ) <= 0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   e3w_0 <= 0' ) 
    1177       IF( MINVAL( gdept_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdept_0 <  0' ) 
    1178       IF( MINVAL( gdepw_0(:,:,:) ) <  0._wp )   CALL ctl_stop( '    zgr_zps :   e r r o r   gdepw_0 <  0' ) 
    1179       
    1180       ! Compute gde3w_0 (vertical sum of e3w) 
    1181       IF ( ln_isfcav ) THEN ! if cavity 
    1182          WHERE( misfdep == 0 )   misfdep = 1 
    1183          DO jj = 1,jpj 
    1184             DO ji = 1,jpi 
    1185                gde3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 
    1186                DO jk = 2, misfdep(ji,jj) 
    1187                   gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
    1188                END DO 
    1189                IF( misfdep(ji,jj) >= 2 )   gde3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 
    1190                DO jk = misfdep(ji,jj) + 1, jpk 
    1191                   gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk)  
    1192                END DO 
    1193             END DO 
    1194          END DO 
    1195       ELSE ! no cavity 
    1196          gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 
    1197          DO jk = 2, jpk 
    1198             gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) 
    1199          END DO 
    1200       END IF 
    1201       ! 
    1202       CALL wrk_dealloc( jpi,jpj,jpk,   zprt ) 
    1203       ! 
    1204       IF( nn_timing == 1 )  CALL timing_stop('zgr_zps') 
    1205       ! 
    1206    END SUBROUTINE zgr_zps 
    1207  
    1208  
    1209    SUBROUTINE zgr_isf 
    1210       !!---------------------------------------------------------------------- 
    1211       !!                    ***  ROUTINE zgr_isf  *** 
    1212       !!    
    1213       !! ** Purpose :   check the bathymetry in levels 
    1214       !!    
    1215       !! ** Method  :   THe water column have to contained at least 2 cells 
    1216       !!                Bathymetry and isfdraft are modified (dig/close) to respect 
    1217       !!                this criterion. 
    1218       !!                  
    1219       !!    
    1220       !! ** Action  : - test compatibility between isfdraft and bathy  
    1221       !!              - bathy and isfdraft are modified 
    1222       !!---------------------------------------------------------------------- 
    1223       INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    1224       INTEGER  ::   ik, it           ! temporary integers 
    1225       INTEGER  ::   id, jd, nprocd 
    1226       INTEGER  ::   icompt, ibtest, ibtestim1, ibtestip1, ibtestjm1, ibtestjp1   ! (ISF) 
    1227       REAL(wp) ::   ze3tp , ze3wp    ! Last ocean level thickness at T- and W-points 
    1228       REAL(wp) ::   zdepwp, zdepth   ! Ajusted ocean depth to avoid too small e3t 
    1229       REAL(wp) ::   zmax, zmin       ! Maximum and minimum depth 
    1230       REAL(wp) ::   zdiff            ! temporary scalar 
    1231       REAL(wp) ::   zrefdep          ! temporary scalar 
    1232       REAL(wp) ::   zbathydiff, zrisfdepdiff  ! isf temporary scalar 
    1233       REAL(wp), POINTER, DIMENSION(:,:)   ::   zrisfdep, zbathy, zmask   ! 2D workspace (ISH) 
    1234       INTEGER , POINTER, DIMENSION(:,:)   ::   zmbathy, zmisfdep         ! 2D workspace (ISH) 
    1235       !!--------------------------------------------------------------------- 
    1236       ! 
    1237       IF( nn_timing == 1 )   CALL timing_start('zgr_isf') 
    1238       ! 
    1239       CALL wrk_alloc( jpi,jpj,   zbathy, zmask, zrisfdep) 
    1240       CALL wrk_alloc( jpi,jpj,   zmisfdep, zmbathy ) 
    1241  
    1242  
    1243       ! (ISF) compute misfdep 
    1244       WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) .NE. 0) ;   misfdep(:,:) = 1   ! open water : set misfdep to 1   
    1245       ELSEWHERE                      ;                          misfdep(:,:) = 2   ! iceshelf : initialize misfdep to second level  
    1246       END WHERE   
    1247  
    1248       ! Compute misfdep for ocean points (i.e. first wet level)  
    1249       ! find the first ocean level such that the first level thickness  
    1250       ! is larger than the bot_level of e3zps_min and e3zps_rat * e3t_0 (where  
    1251       ! e3t_0 is the reference level thickness  
    1252       DO jk = 2, jpkm1  
    1253          zdepth = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat )  
    1254          WHERE( 0._wp < risfdep(:,:) .AND. risfdep(:,:) >= zdepth )   misfdep(:,:) = jk+1  
    12551828      END DO  
    1256       WHERE (risfdep(:,:) <= e3t_1d(1) .AND. risfdep(:,:) > 0._wp) 
    1257          risfdep(:,:) = 0.   ;   misfdep(:,:) = 1 
    1258       END WHERE 
    1259   
    1260 ! basic check for the compatibility of bathy and risfdep. I think it should be offline because it is not perfect and cannot solved all the situation 
    1261       icompt = 0  
    1262 ! run the bathy check 10 times to be sure all the modif in the bathy or iceshelf draft are compatible together 
    1263       DO jl = 1, 10      
    1264          WHERE (bathy(:,:) == risfdep(:,:) ) 
    1265             misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp 
    1266             mbathy (:,:) = 0 ; bathy  (:,:) = 0._wp 
    1267          END WHERE 
    1268          WHERE (mbathy(:,:) <= 0)  
    1269             misfdep(:,:) = 0; risfdep(:,:) = 0._wp  
    1270             mbathy (:,:) = 0; bathy  (:,:) = 0._wp 
    1271          END WHERE 
    1272          IF( lk_mpp ) THEN 
    1273             zbathy(:,:) = FLOAT( misfdep(:,:) ) 
    1274             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1275             misfdep(:,:) = INT( zbathy(:,:) ) 
    1276             CALL lbc_lnk( risfdep, 'T', 1. ) 
    1277             CALL lbc_lnk( bathy, 'T', 1. ) 
    1278             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1279             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1280             mbathy(:,:) = INT( zbathy(:,:) ) 
    1281          ENDIF 
    1282          IF( nperio == 1 .OR. nperio  ==  4 .OR. nperio  ==  6 ) THEN  
    1283             misfdep( 1 ,:) = misfdep(jpim1,:)           ! local domain is cyclic east-west  
    1284             misfdep(jpi,:) = misfdep(  2  ,:)  
    1285          ENDIF 
    1286  
    1287          IF( nperio == 1 .OR. nperio  ==  4 .OR. nperio  ==  6 ) THEN 
    1288             mbathy( 1 ,:) = mbathy(jpim1,:)             ! local domain is cyclic east-west 
    1289             mbathy(jpi,:) = mbathy(  2  ,:) 
    1290          ENDIF 
    1291  
    1292          ! split last cell if possible (only where water column is 2 cell or less) 
    1293          DO jk = jpkm1, 1, -1 
    1294             zmax = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
    1295             WHERE( gdepw_1d(jk) < bathy(:,:) .AND. bathy(:,:) <= zmax .AND. misfdep + 1 >= mbathy) 
    1296                mbathy(:,:) = jk 
    1297                bathy(:,:)  = zmax 
    1298             END WHERE 
    1299          END DO 
    1300   
    1301          ! split top cell if possible (only where water column is 2 cell or less) 
    1302          DO jk = 2, jpkm1 
    1303             zmax = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 
    1304             WHERE( gdepw_1d(jk+1) > risfdep(:,:) .AND. risfdep(:,:) >= zmax .AND. misfdep + 1 >= mbathy) 
    1305                misfdep(:,:) = jk 
    1306                risfdep(:,:) = zmax 
    1307             END WHERE 
    1308          END DO 
    1309  
    1310   
    1311  ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition 
    1312          DO jj = 1, jpj 
    1313             DO ji = 1, jpi 
    1314                ! find the minimum change option: 
    1315                ! test bathy 
    1316                IF (risfdep(ji,jj) > 1) THEN 
    1317                zbathydiff =ABS(bathy(ji,jj)   - (gdepw_1d(mbathy (ji,jj)+1) & 
    1318                  &   + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 
    1319                zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj)  ) & 
    1320                  &   - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 
    1321   
    1322                   IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) < misfdep(ji,jj)) THEN 
    1323                      IF (zbathydiff .LE. zrisfdepdiff) THEN 
    1324                         bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj)+1)*e3zps_rat ) 
    1325                         mbathy(ji,jj)= mbathy(ji,jj) + 1 
    1326                      ELSE 
    1327                         risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 
    1328                         misfdep(ji,jj) = misfdep(ji,jj) - 1 
    1329                      END IF 
    1330                   END IF 
    1331                END IF 
    1332             END DO 
    1333          END DO 
    1334   
    1335           ! At least 2 levels for water thickness at T, U, and V point. 
    1336          DO jj = 1, jpj 
    1337             DO ji = 1, jpi 
    1338                ! find the minimum change option: 
    1339                ! test bathy 
    1340                IF( misfdep(ji,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 
    1341                   zbathydiff  =ABS(bathy(ji,jj)  - (gdepw_1d(mbathy (ji,jj)+1)& 
    1342                     & + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 
    1343                   zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj)  )  & 
    1344                     & - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 
    1345                   IF (zbathydiff .LE. zrisfdepdiff) THEN 
    1346                      mbathy(ji,jj) = mbathy(ji,jj) + 1 
    1347                      bathy(ji,jj)  = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 
    1348                   ELSE 
    1349                      misfdep(ji,jj)= misfdep(ji,jj) - 1 
    1350                      risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 
    1351                   END IF 
    1352                ENDIF 
    1353             END DO 
    1354          END DO 
    1355   
    1356  ! point V mbathy(ji,jj) EQ misfdep(ji,jj+1)  
    1357          DO jj = 1, jpjm1 
    1358             DO ji = 1, jpim1 
    1359                IF( misfdep(ji,jj+1) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 
    1360                   zbathydiff =ABS(bathy(ji,jj    ) - (gdepw_1d(mbathy (ji,jj)+1)   & 
    1361                     &   + MIN( e3zps_min, e3t_1d(mbathy (ji,jj  )+1)*e3zps_rat ))) 
    1362                   zrisfdepdiff=ABS(risfdep(ji,jj+1) - (gdepw_1d(misfdep(ji,jj+1))  & 
    1363                     &  - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 
    1364                   IF (zbathydiff .LE. zrisfdepdiff) THEN 
    1365                      mbathy(ji,jj) = mbathy(ji,jj) + 1 
    1366                      bathy(ji,jj)  = gdepw_1d(mbathy (ji,jj  )) & 
    1367                    &    + MIN( e3zps_min, e3t_1d(mbathy(ji,jj   )+1)*e3zps_rat ) 
    1368                   ELSE 
    1369                      misfdep(ji,jj+1)  = misfdep(ji,jj+1) - 1 
    1370                      risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) & 
    1371                    &   - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 
    1372                   END IF 
    1373                ENDIF 
    1374             END DO 
    1375          END DO 
    1376   
    1377          IF( lk_mpp ) THEN 
    1378             zbathy(:,:) = FLOAT( misfdep(:,:) ) 
    1379             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1380             misfdep(:,:) = INT( zbathy(:,:) ) 
    1381             CALL lbc_lnk( risfdep, 'T', 1. ) 
    1382             CALL lbc_lnk( bathy, 'T', 1. ) 
    1383             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1384             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1385             mbathy(:,:) = INT( zbathy(:,:) ) 
    1386          ENDIF 
    1387  ! point V misdep(ji,jj) EQ mbathy(ji,jj+1)  
    1388          DO jj = 1, jpjm1 
    1389             DO ji = 1, jpim1 
    1390                IF( misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) .GT. 1) THEN 
    1391                   zbathydiff =ABS(  bathy(ji,jj+1) - (gdepw_1d(mbathy (ji,jj+1)+1) & 
    1392                    &   + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 
    1393                   zrisfdepdiff=ABS(risfdep(ji,jj  ) - (gdepw_1d(misfdep(ji,jj  )  )  & 
    1394                    &   - MIN( e3zps_min, e3t_1d(misfdep(ji,jj  )-1)*e3zps_rat ))) 
    1395                   IF (zbathydiff .LE. zrisfdepdiff) THEN 
    1396                      mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 
    1397                      bathy  (ji,jj+1) = gdepw_1d(mbathy (ji,jj+1)  ) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ) 
    1398                   ELSE 
    1399                      misfdep(ji,jj)   = misfdep(ji,jj) - 1 
    1400                      risfdep(ji,jj)   = gdepw_1d(misfdep(ji,jj  )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj  )  )*e3zps_rat ) 
    1401                   END IF 
    1402                ENDIF 
    1403             END DO 
    1404          END DO 
    1405   
    1406   
    1407          IF( lk_mpp ) THEN  
    1408             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1409             CALL lbc_lnk( zbathy, 'T', 1. )  
    1410             misfdep(:,:) = INT( zbathy(:,:) )  
    1411             CALL lbc_lnk( risfdep, 'T', 1. )  
    1412             CALL lbc_lnk( bathy, 'T', 1. ) 
    1413             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1414             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1415             mbathy(:,:) = INT( zbathy(:,:) ) 
    1416          ENDIF  
    1417   
    1418  ! point U mbathy(ji,jj) EQ misfdep(ji,jj+1)  
    1419          DO jj = 1, jpjm1 
    1420             DO ji = 1, jpim1 
    1421                IF( misfdep(ji+1,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 
    1422                   zbathydiff =ABS(  bathy(ji  ,jj) - (gdepw_1d(mbathy (ji,jj)+1) & 
    1423                     &   + MIN( e3zps_min, e3t_1d(mbathy (ji  ,jj)+1)*e3zps_rat ))) 
    1424                   zrisfdepdiff=ABS(risfdep(ji+1,jj) - (gdepw_1d(misfdep(ji+1,jj)) & 
    1425                     &  - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 
    1426                   IF (zbathydiff .LE. zrisfdepdiff) THEN 
    1427                      mbathy(ji,jj) = mbathy(ji,jj) + 1 
    1428                      bathy(ji,jj)  = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 
    1429                   ELSE 
    1430                      misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 
    1431                      risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 
    1432                   END IF 
    1433                ENDIF 
    1434             ENDDO 
    1435          ENDDO 
    1436   
    1437          IF( lk_mpp ) THEN  
    1438             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1439             CALL lbc_lnk( zbathy, 'T', 1. )  
    1440             misfdep(:,:) = INT( zbathy(:,:) )  
    1441             CALL lbc_lnk( risfdep, 'T', 1. )  
    1442             CALL lbc_lnk( bathy, 'T', 1. ) 
    1443             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1444             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1445             mbathy(:,:) = INT( zbathy(:,:) ) 
    1446          ENDIF  
    1447   
    1448  ! point U misfdep(ji,jj) EQ bathy(ji,jj+1)  
    1449          DO jj = 1, jpjm1 
    1450             DO ji = 1, jpim1 
    1451                IF( misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) .GT. 1) THEN 
    1452                   zbathydiff =ABS(  bathy(ji+1,jj) - (gdepw_1d(mbathy (ji+1,jj)+1) & 
    1453                       &   + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 
    1454                   zrisfdepdiff=ABS(risfdep(ji  ,jj) - (gdepw_1d(misfdep(ji  ,jj)  )  & 
    1455                       &  - MIN( e3zps_min, e3t_1d(misfdep(ji  ,jj)-1)*e3zps_rat ))) 
    1456                   IF (zbathydiff .LE. zrisfdepdiff) THEN 
    1457                      mbathy(ji+1,jj)  = mbathy (ji+1,jj) + 1 
    1458                      bathy (ji+1,jj)  = gdepw_1d(mbathy (ji+1,jj)  )  & 
    1459                       &   + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 
    1460                   ELSE 
    1461                      misfdep(ji,jj)   = misfdep(ji  ,jj) - 1 
    1462                      risfdep(ji,jj)   = gdepw_1d(misfdep(ji  ,jj)+1) & 
    1463                       &   - MIN( e3zps_min, e3t_1d(misfdep(ji  ,jj)   )*e3zps_rat ) 
    1464                   END IF 
    1465                ENDIF 
    1466             ENDDO 
    1467          ENDDO 
    1468   
    1469          IF( lk_mpp ) THEN 
    1470             zbathy(:,:) = FLOAT( misfdep(:,:) ) 
    1471             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1472             misfdep(:,:) = INT( zbathy(:,:) ) 
    1473             CALL lbc_lnk( risfdep, 'T', 1. ) 
    1474             CALL lbc_lnk( bathy, 'T', 1. ) 
    1475             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1476             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1477             mbathy(:,:) = INT( zbathy(:,:) ) 
    1478          ENDIF 
    1479       END DO 
    1480       ! end dig bathy/ice shelf to be compatible 
    1481       ! now fill single point in "coastline" of ice shelf, bathy, hole, and test again one cell tickness 
    1482       DO jl = 1,20 
    1483   
    1484  ! remove single point "bay" on isf coast line in the ice shelf draft' 
    1485          DO jk = 2, jpk 
    1486             WHERE (misfdep==0) misfdep=jpk 
    1487             zmask=0 
    1488             WHERE (misfdep .LE. jk) zmask=1 
    1489             DO jj = 2, jpjm1 
    1490                DO ji = 2, jpim1 
    1491                   IF (misfdep(ji,jj) .EQ. jk) THEN 
    1492                      ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) 
    1493                      IF (ibtest .LE. 1) THEN 
    1494                         risfdep(ji,jj)=gdepw_1d(jk+1) ; misfdep(ji,jj)=jk+1 
    1495                         IF (misfdep(ji,jj) .GT. mbathy(ji,jj)) misfdep(ji,jj) = jpk 
    1496                      END IF 
    1497                   END IF 
    1498                END DO 
    1499             END DO 
    1500          END DO 
    1501          WHERE (misfdep==jpk) 
    1502              misfdep=0 ; risfdep=0. ; mbathy=0 ; bathy=0. 
    1503          END WHERE 
    1504          IF( lk_mpp ) THEN 
    1505             zbathy(:,:) = FLOAT( misfdep(:,:) ) 
    1506             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1507             misfdep(:,:) = INT( zbathy(:,:) ) 
    1508             CALL lbc_lnk( risfdep, 'T', 1. ) 
    1509             CALL lbc_lnk( bathy, 'T', 1. ) 
    1510             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1511             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1512             mbathy(:,:) = INT( zbathy(:,:) ) 
    1513          ENDIF 
    1514   
    1515  ! remove single point "bay" on bathy coast line beneath an ice shelf' 
    1516          DO jk = jpk,1,-1 
    1517             zmask=0 
    1518             WHERE (mbathy .GE. jk ) zmask=1 
    1519             DO jj = 2, jpjm1 
    1520                DO ji = 2, jpim1 
    1521                   IF (mbathy(ji,jj) .EQ. jk .AND. misfdep(ji,jj) .GE. 2) THEN 
    1522                      ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) 
    1523                      IF (ibtest .LE. 1) THEN 
    1524                         bathy(ji,jj)=gdepw_1d(jk) ; mbathy(ji,jj)=jk-1 
    1525                         IF (misfdep(ji,jj) .GT. mbathy(ji,jj)) mbathy(ji,jj) = 0 
    1526                      END IF 
    1527                   END IF 
    1528                END DO 
    1529             END DO 
    1530          END DO 
    1531          WHERE (mbathy==0) 
    1532              misfdep=0 ; risfdep=0. ; mbathy=0 ; bathy=0. 
    1533          END WHERE 
    1534          IF( lk_mpp ) THEN 
    1535             zbathy(:,:) = FLOAT( misfdep(:,:) ) 
    1536             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1537             misfdep(:,:) = INT( zbathy(:,:) ) 
    1538             CALL lbc_lnk( risfdep, 'T', 1. ) 
    1539             CALL lbc_lnk( bathy, 'T', 1. ) 
    1540             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1541             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1542             mbathy(:,:) = INT( zbathy(:,:) ) 
    1543          ENDIF 
    1544   
    1545  ! fill hole in ice shelf 
    1546          zmisfdep = misfdep 
    1547          zrisfdep = risfdep 
    1548          WHERE (zmisfdep .LE. 1) zmisfdep=jpk 
    1549          DO jj = 2, jpjm1 
    1550             DO ji = 2, jpim1 
    1551                ibtestim1 = zmisfdep(ji-1,jj  ) ; ibtestip1 = zmisfdep(ji+1,jj  ) 
    1552                ibtestjm1 = zmisfdep(ji  ,jj-1) ; ibtestjp1 = zmisfdep(ji  ,jj+1) 
    1553                IF( zmisfdep(ji,jj) .GE. mbathy(ji-1,jj  ) ) ibtestim1 = jpk!MAX(0, mbathy(ji-1,jj  ) - 1) 
    1554                IF( zmisfdep(ji,jj) .GE. mbathy(ji+1,jj  ) ) ibtestip1 = jpk!MAX(0, mbathy(ji+1,jj  ) - 1) 
    1555                IF( zmisfdep(ji,jj) .GE. mbathy(ji  ,jj-1) ) ibtestjm1 = jpk!MAX(0, mbathy(ji  ,jj-1) - 1) 
    1556                IF( zmisfdep(ji,jj) .GE. mbathy(ji  ,jj+1) ) ibtestjp1 = jpk!MAX(0, mbathy(ji  ,jj+1) - 1) 
    1557                ibtest=MIN(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 
    1558                IF( ibtest == jpk .AND. misfdep(ji,jj) .GE. 2) THEN 
    1559                   mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp 
    1560                END IF 
    1561                IF( zmisfdep(ji,jj) < ibtest .AND. misfdep(ji,jj) .GE. 2) THEN 
    1562                   misfdep(ji,jj) = ibtest 
    1563                   risfdep(ji,jj) = gdepw_1d(ibtest) 
    1564                ENDIF 
    1565             ENDDO 
    1566          ENDDO 
    1567   
    1568          IF( lk_mpp ) THEN  
    1569             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1570             CALL lbc_lnk( zbathy, 'T', 1. )  
    1571             misfdep(:,:) = INT( zbathy(:,:) )  
    1572             CALL lbc_lnk( risfdep, 'T', 1. )  
    1573             CALL lbc_lnk( bathy, 'T', 1. ) 
    1574             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1575             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1576             mbathy(:,:) = INT( zbathy(:,:) ) 
    1577          ENDIF  
    1578  ! 
    1579  !! fill hole in bathymetry 
    1580          zmbathy (:,:)=mbathy (:,:) 
    1581          DO jj = 2, jpjm1 
    1582             DO ji = 2, jpim1 
    1583                ibtestim1 = zmbathy(ji-1,jj  ) ; ibtestip1 = zmbathy(ji+1,jj  ) 
    1584                ibtestjm1 = zmbathy(ji  ,jj-1) ; ibtestjp1 = zmbathy(ji  ,jj+1) 
    1585                IF( zmbathy(ji,jj) .LT. misfdep(ji-1,jj  ) ) ibtestim1 = 0!MIN(jpk-1, misfdep(ji-1,jj  ) + 1) 
    1586                IF( zmbathy(ji,jj) .LT. misfdep(ji+1,jj  ) ) ibtestip1 = 0 
    1587                IF( zmbathy(ji,jj) .LT. misfdep(ji  ,jj-1) ) ibtestjm1 = 0 
    1588                IF( zmbathy(ji,jj) .LT. misfdep(ji  ,jj+1) ) ibtestjp1 = 0 
    1589                ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 
    1590                IF( ibtest == 0 .AND. misfdep(ji,jj) .GE. 2) THEN 
    1591                   mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; 
    1592                END IF 
    1593                IF( ibtest < zmbathy(ji,jj) .AND. misfdep(ji,jj) .GE. 2) THEN 
    1594                   mbathy(ji,jj) = ibtest 
    1595                   bathy(ji,jj)  = gdepw_1d(ibtest+1)  
    1596                ENDIF 
    1597             END DO 
    1598          END DO 
    1599          IF( lk_mpp ) THEN  
    1600             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1601             CALL lbc_lnk( zbathy, 'T', 1. )  
    1602             misfdep(:,:) = INT( zbathy(:,:) )  
    1603             CALL lbc_lnk( risfdep, 'T', 1. )  
    1604             CALL lbc_lnk( bathy, 'T', 1. ) 
    1605             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1606             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1607             mbathy(:,:) = INT( zbathy(:,:) ) 
    1608          ENDIF  
    1609  ! if not compatible after all check (ie U point water column less than 2 cells), mask U 
    1610          DO jj = 1, jpjm1 
    1611             DO ji = 1, jpim1 
    1612                IF (mbathy(ji,jj) == misfdep(ji+1,jj) .AND. mbathy(ji,jj) .GE. 1 .AND. mbathy(ji+1,jj) .GE. 1) THEN 
    1613                   mbathy(ji,jj)  = mbathy(ji,jj) - 1 ; bathy(ji,jj)   = gdepw_1d(mbathy(ji,jj)+1) ; 
    1614                END IF 
    1615             END DO 
    1616          END DO 
    1617          IF( lk_mpp ) THEN  
    1618             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1619             CALL lbc_lnk( zbathy, 'T', 1. )  
    1620             misfdep(:,:) = INT( zbathy(:,:) )  
    1621             CALL lbc_lnk( risfdep, 'T', 1. )  
    1622             CALL lbc_lnk( bathy, 'T', 1. ) 
    1623             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1624             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1625             mbathy(:,:) = INT( zbathy(:,:) ) 
    1626          ENDIF  
    1627  ! if not compatible after all check (ie U point water column less than 2 cells), mask U 
    1628          DO jj = 1, jpjm1 
    1629             DO ji = 1, jpim1 
    1630                IF (misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) .GE. 1 .AND. mbathy(ji+1,jj) .GE. 1) THEN 
    1631                   mbathy(ji+1,jj)  = mbathy(ji+1,jj) - 1;   bathy(ji+1,jj)   = gdepw_1d(mbathy(ji+1,jj)+1) ; 
    1632                END IF 
    1633             END DO 
    1634          END DO 
    1635          IF( lk_mpp ) THEN  
    1636             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1637             CALL lbc_lnk( zbathy, 'T', 1. )  
    1638             misfdep(:,:) = INT( zbathy(:,:) )  
    1639             CALL lbc_lnk( risfdep, 'T', 1. )  
    1640             CALL lbc_lnk( bathy, 'T', 1. ) 
    1641             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1642             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1643             mbathy(:,:) = INT( zbathy(:,:) ) 
    1644          ENDIF  
    1645  ! if not compatible after all check (ie V point water column less than 2 cells), mask V 
    1646          DO jj = 1, jpjm1 
    1647             DO ji = 1, jpi 
    1648                IF (mbathy(ji,jj) == misfdep(ji,jj+1) .AND. mbathy(ji,jj) .GE. 1 .AND. mbathy(ji,jj+1) .GE. 1) THEN 
    1649                   mbathy(ji,jj)  = mbathy(ji,jj) - 1 ; bathy(ji,jj)   = gdepw_1d(mbathy(ji,jj)+1) ; 
    1650                END IF 
    1651             END DO 
    1652          END DO 
    1653          IF( lk_mpp ) THEN  
    1654             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1655             CALL lbc_lnk( zbathy, 'T', 1. )  
    1656             misfdep(:,:) = INT( zbathy(:,:) )  
    1657             CALL lbc_lnk( risfdep, 'T', 1. )  
    1658             CALL lbc_lnk( bathy, 'T', 1. ) 
    1659             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1660             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1661             mbathy(:,:) = INT( zbathy(:,:) ) 
    1662          ENDIF  
    1663  ! if not compatible after all check (ie V point water column less than 2 cells), mask V 
    1664          DO jj = 1, jpjm1 
    1665             DO ji = 1, jpi 
    1666                IF (misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) .GE. 1 .AND. mbathy(ji,jj+1) .GE. 1) THEN 
    1667                   mbathy(ji,jj+1)  = mbathy(ji,jj+1) - 1 ; bathy(ji,jj+1)   = gdepw_1d(mbathy(ji,jj+1)+1) ; 
    1668                END IF 
    1669             END DO 
    1670          END DO 
    1671          IF( lk_mpp ) THEN  
    1672             zbathy(:,:) = FLOAT( misfdep(:,:) )  
    1673             CALL lbc_lnk( zbathy, 'T', 1. )  
    1674             misfdep(:,:) = INT( zbathy(:,:) )  
    1675             CALL lbc_lnk( risfdep, 'T', 1. )  
    1676             CALL lbc_lnk( bathy, 'T', 1. ) 
    1677             zbathy(:,:) = FLOAT( mbathy(:,:) ) 
    1678             CALL lbc_lnk( zbathy, 'T', 1. ) 
    1679             mbathy(:,:) = INT( zbathy(:,:) ) 
    1680          ENDIF  
    1681  ! if not compatible after all check, mask T 
    1682          DO jj = 1, jpj 
    1683             DO ji = 1, jpi 
    1684                IF (mbathy(ji,jj) <= misfdep(ji,jj)) THEN 
    1685                   misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0._wp ; mbathy(ji,jj)  = 0 ; bathy(ji,jj)   = 0._wp ; 
    1686                END IF 
    1687             END DO 
    1688          END DO 
    1689   
    1690          WHERE (mbathy(:,:) == 1) 
    1691             mbathy = 0; bathy = 0.0_wp ; misfdep = 0 ; risfdep = 0.0_wp 
    1692          END WHERE 
    1693       END DO  
    1694 ! end check compatibility ice shelf/bathy 
    1695       ! remove very shallow ice shelf (less than ~ 10m if 75L) 
    1696       WHERE (misfdep(:,:) <= 5) 
    1697          misfdep = 1; risfdep = 0.0_wp; 
    1698       END WHERE 
    1699  
    1700       IF( icompt == 0 ) THEN  
    1701          IF(lwp) WRITE(numout,*)'     no points with ice shelf too close to bathymetry'  
    1702       ELSE  
    1703          IF(lwp) WRITE(numout,*)'    ',icompt,' ocean grid points with ice shelf thickness reduced to avoid bathymetry'  
    1704       ENDIF  
    17051829 
    17061830      CALL wrk_dealloc( jpi, jpj, zmask, zbathy, zrisfdep ) 
    … …  
    17091833      IF( nn_timing == 1 )   CALL timing_stop('zgr_isf') 
    17101834      !       
    1711    END SUBROUTINE 
     1835   END SUBROUTINE zgr_isf 
    17121836 
    17131837 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r6060 r6069  
    3535   USE dtauvd          ! data: U & V current             (dta_uvd routine) 
    3636   USE domvvl          ! varying vertical mesh 
     37   USE iscplrst        ! ice sheet coupling 
    3738   ! 
    3839   USE in_out_manager  ! I/O manager 
    … …  
    8485      IF( ln_rstart ) THEN                    ! Restart from a file 
    8586         !                                    ! ------------------- 
    86          CALL rst_read                           ! Read the restart file 
    87          CALL day_init                           ! model calendar (using both namelist and restart infos) 
     87         CALL rst_read                        ! Read the restart file 
     88         IF (ln_iscpl)       CALL iscpl_stp   ! extraloate restart to wet and dry 
     89         CALL day_init                        ! model calendar (using both namelist and restart infos) 
    8890      ELSE 
    8991         !                                    ! Start from rest 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DYN/divhor.F90

    r6060 r6069  
    2020   USE oce             ! ocean dynamics and tracers 
    2121   USE dom_oce         ! ocean space and time domain 
    22    USE sbc_oce, ONLY : ln_rnf, nn_isf ! surface boundary condition: ocean 
     22   USE sbc_oce, ONLY : ln_rnf, ln_isf ! surface boundary condition: ocean 
    2323   USE sbcrnf          ! river runoff  
    2424   USE sbcisf          ! ice shelf 
     25   USE iscplhsb        ! ice sheet / ocean coupling 
     26   USE iscplini        ! ice sheet / ocean coupling 
    2527   ! 
    2628   USE in_out_manager  ! I/O manager 
    … …  
    8890      END DO 
    8991      ! 
    90       IF( ln_rnf                     )   CALL sbc_rnf_div( hdivn )      !==  runoffs    ==!   (update hdivn field) 
     92      IF( ln_rnf )   CALL sbc_rnf_div( hdivn )      !==  runoffs    ==!   (update hdivn field) 
    9193      ! 
    92       IF( ln_divisf .AND. nn_isf > 0 )   CALL sbc_isf_div( hdivn )      !==  ice shelf  ==!   (update hdivn field) 
     94      IF( ln_isf )   CALL sbc_isf_div( hdivn )      !==  ice shelf  ==!   (update hdivn field) 
    9395      ! 
    94       CALL lbc_lnk( hdivn, 'T', 1. )                       !==  lateral boundary cond.  ==!   (no sign change) 
     96      IF( ln_iscpl .AND. ln_hsb ) CALL iscpl_div( hdivn )  !==  ice sheet  ==!   (update hdivn field) 
     97      ! 
     98      CALL lbc_lnk( hdivn, 'T', 1. )                !==  lateral boundary cond.  ==!   (no sign change) 
    9599      ! 
    96100      IF( nn_timing == 1 )  CALL timing_stop('div_hor') 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r6060 r6069  
    4545   USE wrk_nemo        ! Memory Allocation 
    4646   USE timing          ! Timing 
     47   USE iom 
    4748 
    4849   IMPLICIT NONE 
    … …  
    129130      INTEGER ::   ioptio = 0      ! temporary integer 
    130131      INTEGER ::   ios             ! Local integer output status for namelist read 
     132      !! 
     133      INTEGER  ::   ji, jj, jk, ikt    ! dummy loop indices      ISF 
     134      REAL(wp) ::   znad 
     135      REAL(wp), POINTER, DIMENSION(:,:,:)   ::  ztstop, zrhd ! hypothesys on isf density 
     136      REAL(wp), POINTER, DIMENSION(:,:)     ::  zrhdtop_isf  ! density at bottom of ISF 
     137      REAL(wp), POINTER, DIMENSION(:,:)     ::  ziceload     ! density at bottom of ISF 
    131138      !! 
    132139      NAMELIST/namdyn_hpg/ ln_hpg_zco, ln_hpg_zps, ln_hpg_sco,     & 
    … …  
    189196      IF( ioptio /= 1 )   CALL ctl_stop( 'NO or several hydrostatic pressure gradient options used' ) 
    190197      !  
    191       ! initialisation of ice load 
    192       riceload(:,:)=0.0 
     198      ! initialisation of ice shelf load 
     199      IF ( .NOT. ln_isfcav ) riceload(:,:)=0.0 
     200      IF (       ln_isfcav ) THEN 
     201         CALL wrk_alloc( jpi,jpj, 2,  ztstop)  
     202         CALL wrk_alloc( jpi,jpj,jpk, zrhd  ) 
     203         CALL wrk_alloc( jpi,jpj,     zrhdtop_isf, ziceload)  
     204         ! 
     205         IF(lwp) WRITE(numout,*) 
     206         IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 
     207         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'   
     208 
     209         ! To use density and not density anomaly 
     210         znad=1._wp 
     211          
     212         ! assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 
     213         ztstop(:,:,1)=-1.9_wp ; ztstop(:,:,2)=34.4_wp 
     214 
     215         ! compute density of the water displaced by the ice shelf  
     216         DO jk = 1, jpk 
     217            CALL eos(ztstop(:,:,:),fsdept_n(:,:,jk),zrhd(:,:,jk)) 
     218         END DO 
     219       
     220         ! compute rhd at the ice/oce interface (ice shelf side) 
     221         CALL eos(ztstop,risfdep,zrhdtop_isf) 
     222 
     223         ! Surface value + ice shelf gradient 
     224         ! compute pressure due to ice shelf load (used to compute hpgi/j for all the level from 1 to miku/v) 
     225         ! divided by 2 later 
     226         ziceload = 0._wp 
     227         DO jj = 1, jpj 
     228            DO ji = 1, jpi 
     229               ikt=mikt(ji,jj) 
     230               ziceload(ji,jj) = ziceload(ji,jj) + (znad + zrhd(ji,jj,1) ) * fse3w(ji,jj,1) * (1._wp - tmask(ji,jj,1)) 
     231               DO jk=2,ikt-1 
     232                  ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * fse3w(ji,jj,jk) & 
     233                     &                              * (1._wp - tmask(ji,jj,jk)) 
     234               END DO 
     235               IF (ikt  >=  2) ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1)) & 
     236                                  &                              * ( risfdep(ji,jj) - gdept_1d(ikt-1) ) 
     237            END DO 
     238         END DO 
     239         riceload(:,:)=ziceload(:,:)  ! need to be saved for diaar5 
     240 
     241         CALL wrk_dealloc( jpi,jpj, 2,  ztstop)  
     242         CALL wrk_dealloc( jpi,jpj,jpk, zrhd  ) 
     243         CALL wrk_dealloc( jpi,jpj,     zrhdtop_isf, ziceload)  
     244      END IF 
    193245      ! 
    194246   END SUBROUTINE dyn_hpg_init 
    … …  
    444496   SUBROUTINE hpg_isf( kt ) 
    445497      !!--------------------------------------------------------------------- 
    446       !!                  ***  ROUTINE hpg_sco  *** 
     498      !!                  ***  ROUTINE hpg_isf  *** 
    447499      !! 
    448500      !! ** Method  :   s-coordinate case. Jacobian scheme. 
    … …  
    463515      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    464516      !! 
    465       INTEGER  ::   ji, jj, jk, iku, ikv, ikt, iktp1i, iktp1j                 ! dummy loop indices 
    466       REAL(wp) ::   zcoef0, zuap, zvap, znad, ze3wu, ze3wv, zuapint, zvapint, zhpjint, zhpiint, zdzwt, zdzwtjp1, zdzwtip1             ! temporary scalars 
    467       REAL(wp), POINTER, DIMENSION(:,:,:)   ::  zhpi, zhpj, zrhd 
     517      INTEGER  ::   ji, jj, jk, ikt, iktp1i, iktp1j   ! dummy loop indices 
     518      REAL(wp) ::   zcoef0, zuap, zvap, znad          ! temporary scalars 
     519      REAL(wp), POINTER, DIMENSION(:,:,:)   ::  zhpi, zhpj 
    468520      REAL(wp), POINTER, DIMENSION(:,:,:)   ::  ztstop 
    469       REAL(wp), POINTER, DIMENSION(:,:)     ::  ze3w, zp, zrhdtop_isf, zrhdtop_oce, ziceload, zdept, zpshpi, zpshpj 
    470       !!---------------------------------------------------------------------- 
    471       ! 
    472       CALL wrk_alloc( jpi,jpj,  2,   ztstop )  
    473       CALL wrk_alloc( jpi,jpj,jpk,   zhpi, zhpj, zrhd) 
    474       CALL wrk_alloc( jpi,jpj,       ze3w, zp, zrhdtop_isf, zrhdtop_oce, ziceload, zdept, zpshpi, zpshpj )  
    475       ! 
    476       IF( kt == nit000 ) THEN 
    477          IF(lwp) WRITE(numout,*) 
    478          IF(lwp) WRITE(numout,*) 'dyn:hpg_isf : hydrostatic pressure gradient trend for ice shelf' 
    479          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate case, OPA original scheme used' 
    480       ENDIF 
    481       ! 
     521      REAL(wp), POINTER, DIMENSION(:,:)     ::  zrhdtop_oce 
     522      !!---------------------------------------------------------------------- 
     523      ! 
     524      CALL wrk_alloc( jpi,jpj,  2, ztstop)  
     525      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zhpj) 
     526      CALL wrk_alloc( jpi,jpj,     zrhdtop_oce ) 
     527      ! 
     528      ! Local constant initialization 
    482529      zcoef0 = - grav * 0.5_wp 
    483       IF( ln_linssh ) THEN   ;   znad = 0._wp      ! Fixed    volume: density anomaly 
    484       ELSE                   ;   znad = 1._wp      ! Variable volume: density 
    485       ENDIF 
    486       zhpi(:,:,:) = 0._wp 
    487       zhpj(:,:,:) = 0._wp 
     530   
     531      ! To use density and not density anomaly 
     532      znad=1._wp 
     533 
     534      ! iniitialised to 0. zhpi zhpi  
     535      zhpi(:,:,:)=0._wp ; zhpj(:,:,:)=0._wp 
     536 
     537      ! compute rhd at the ice/oce interface (ocean side) 
     538      ! usefull to reduce residual current in the test case ISOMIP with no melting 
     539      DO ji=1,jpi 
     540        DO jj=1,jpj 
     541          ikt=mikt(ji,jj) 
     542          ztstop(ji,jj,1)=tsn(ji,jj,ikt,1) 
     543          ztstop(ji,jj,2)=tsn(ji,jj,ikt,2) 
     544        END DO 
     545      END DO 
     546      CALL eos( ztstop, risfdep, zrhdtop_oce ) 
    488547 
    489548!==================================================================================      
    490 !=====Compute iceload and contribution of the half first wet layer =================  
    491 !=================================================================================== 
    492  
    493       ! assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 
    494       ztstop(:,:,jp_tem) = -1.9_wp 
    495       ztstop(:,:,jp_sal) = 34.4_wp 
    496  
    497 !!gm I have the feeling that a much simplier and faster computation can be performed... 
    498 !!gm     ====>>>>   We have to discuss ! 
    499  
    500 !!gm below, faster to compute the ISF density in zrhd and remplace rhd value where tmask=0 
    501 !!gm        furthermore, this calculation does not depends on time :  do it at the first time-step only.... 
    502  
    503       ! compute density of the water displaced by the ice shelf  
    504       zrhd(:,:,:) = rhd(:,:,:)     ! save rhd 
    505       DO jk = 1, jpk 
    506          zdept(:,:) = gdept_1d(jk) 
    507          CALL eos( ztstop(:,:,:), zdept(:,:), rhd(:,:,jk) ) 
    508       END DO 
    509       WHERE( tmask(:,:,:) == 1._wp ) 
    510         rhd(:,:,:) = zrhd(:,:,:) ! replace wet cell by the saved rhd 
    511       END WHERE 
    512        
    513       ! compute rhd at the ice/oce interface (ice shelf side) 
    514       CALL eos( ztstop, risfdep, zrhdtop_isf ) 
    515  
    516       ! compute rhd at the ice/oce interface (ocean side) 
    517       DO ji = 1, jpi 
    518         DO jj = 1, jpj 
    519           ikt = mikt(ji,jj) 
    520           ztstop(ji,jj,jp_tem) = tsn(ji,jj,ikt,jp_tem) 
    521           ztstop(ji,jj,jp_sal) = tsn(ji,jj,ikt,jp_sal) 
    522         END DO 
    523       END DO 
    524       CALL eos( ztstop, risfdep, zrhdtop_oce ) 
    525       ! 
    526       ! Surface value + ice shelf gradient 
    527       ! compute pressure due to ice shelf load (used to compute hpgi/j for all the level from 1 to miku/v) 
    528       ziceload = 0._wp 
    529       DO jj = 1, jpj 
    530          DO ji = 1, jpi   ! vector opt. 
    531             ikt = mikt(ji,jj) 
    532             ziceload(ji,jj) = ziceload(ji,jj) + (znad + rhd(ji,jj,1) ) * e3w_n(ji,jj,1) * (1._wp - tmask(ji,jj,1)) 
    533             DO jk = 2, ikt-1 
    534                ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + rhd(ji,jj,jk-1) + rhd(ji,jj,jk)) * e3w_n(ji,jj,jk) & 
    535                   &                              * (1._wp - tmask(ji,jj,jk)) 
    536             END DO 
    537             IF( ikt >= 2 )   ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + rhd(ji,jj,ikt-1)) & 
    538                &                                               * ( risfdep(ji,jj) - gdept_1d(ikt-1) ) 
    539          END DO 
    540       END DO 
    541       riceload(:,:) = 0._wp   ;   riceload(:,:) = ziceload(:,:)   ! need to be saved for diaar5 
    542       ! compute zp from z=0 to first T wet point (correction due to zps not yet applied) 
     549!===== Compute surface value =====================================================  
     550!================================================================================== 
    543551      DO jj = 2, jpjm1 
    544552         DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    548556            ! hydrostatic pressure gradient along s-surfaces and ice shelf pressure 
    549557            ! we assume ISF is in isostatic equilibrium 
    550             zhpi(ji,jj,1) = zcoef0 * (                                    & 
    551                &            0.5_wp * e3w_n(ji+1,jj,iktp1i) * ( 2._wp * znad + rhd(ji+1,jj,iktp1i) + zrhdtop_oce(ji+1,jj) )   & 
    552                &          - 0.5_wp * e3w_n(ji  ,jj,ikt   ) * ( 2._wp * znad + rhd(ji  ,jj,ikt   ) + zrhdtop_oce(ji  ,jj) )   & 
    553                &          + ( ziceload(ji+1,jj) - ziceload(ji,jj) )       ) * r1_e1u(ji,jj) 
    554             zhpj(ji,jj,1) = zcoef0 * (                                    & 
    555                &            0.5_wp * e3w_n(ji,jj+1,iktp1j) * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) )   & 
    556                &          - 0.5_wp * e3w_n(ji,jj  ,ikt   ) * ( 2._wp * znad + rhd(ji,jj  ,ikt   ) + zrhdtop_oce(ji,jj  ) )   & 
    557                &          + ( ziceload(ji,jj+1) - ziceload(ji,jj) )       ) * r1_e2v(ji,jj) 
     558            zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( 0.5_wp * e3w_n(ji+1,jj,iktp1i)                                    & 
     559               &                                    * ( 2._wp * znad + rhd(ji+1,jj,iktp1i) + zrhdtop_oce(ji+1,jj) )   & 
     560               &                                  - 0.5_wp * e3w_n(ji,jj,ikt)                                         & 
     561               &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
     562               &                                  + ( riceload(ji+1,jj) - riceload(ji,jj))                            )  
     563            zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w_n(ji,jj+1,iktp1j)                                    & 
     564               &                                    * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) )   & 
     565               &                                  - 0.5_wp * e3w_n(ji,jj,ikt)                                         &  
     566               &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
     567               &                                  + ( riceload(ji,jj+1) - riceload(ji,jj))                            )  
    558568            ! s-coordinate pressure gradient correction (=0 if z coordinate) 
    559569            zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    … …  
    567577      END DO 
    568578!==================================================================================      
    569 !===== Compute partial cell contribution for the top cell =========================  
    570 !================================================================================== 
    571       DO jj = 2, jpjm1 
    572          DO ji = fs_2, fs_jpim1   ! vector opt. 
    573             iku = miku(ji,jj) 
    574             zpshpi(ji,jj) = 0._wp 
    575             zpshpj(ji,jj) = 0._wp 
    576             ze3wu  = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 
    577             ! u direction 
    578             IF( iku > 1 ) THEN 
    579                ! case iku 
    580                zhpi(ji,jj,iku) = zcoef0 * r1_e1u(ji,jj) * ze3wu                             & 
    581                   &                     * ( rhd(ji+1,jj,iku) + rhd(ji,jj,iku)               & 
    582                   &                        + SIGN(1._wp,ze3wu) * grui(ji,jj) + 2._wp * znad ) 
    583                ! corrective term ( = 0 if z coordinate ) 
    584                zuap = -zcoef0 * ( arui(ji,jj) + 2._wp * znad ) * gzui(ji,jj) * r1_e1u(ji,jj) 
    585                ! zhpi will be added in interior loop 
    586                ua(ji,jj,iku) = ua(ji,jj,iku) + zuap 
    587                ! in case of 2 cell water column, need to save the pressure gradient to compute the bottom pressure   
    588                IF( mbku(ji,jj) == iku + 1 )   zpshpi(ji,jj) = zhpi(ji,jj,iku) 
    589  
    590                ! case iku + 1 (remove the zphi term added in the interior loop and compute the one corrected for zps) 
    591                zhpiint = zcoef0 * r1_e1u(ji,jj)                                                              &     
    592                   &    * (  e3w_n(ji+1,jj  ,iku+1) * (  (rhd(ji+1,jj,iku+1) + znad)                          & 
    593                   &                                   + (rhd(ji+1,jj,iku  ) + znad) ) * tmask(ji+1,jj,iku)   & 
    594                   &       - e3w_n(ji  ,jj  ,iku+1) * (  (rhd(ji  ,jj,iku+1) + znad)                          & 
    595                   &                                   + (rhd(ji  ,jj,iku  ) + znad) ) * tmask(ji  ,jj,iku)   ) 
    596                zhpi(ji,jj,iku+1) = zcoef0 * r1_e1u(ji,jj) * ge3rui(ji,jj) - zhpiint  
    597             END IF 
    598                 
    599             ! v direction 
    600             ikv = mikv(ji,jj) 
    601             ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    602             IF( ikv > 1 ) THEN 
    603                ! case ikv 
    604                zhpj(ji,jj,ikv) =  zcoef0 * r1_e2v(ji,jj) * ze3wv                             & 
    605                   &                      * ( rhd(ji,jj+1,ikv) + rhd(ji,jj,ikv)               & 
    606                   &                         + SIGN(1._wp,ze3wv) * grvi(ji,jj) + 2._wp * znad ) 
    607                ! corrective term ( = 0 if z coordinate ) 
    608                zvap = -zcoef0 * ( arvi(ji,jj) + 2._wp * znad ) * gzvi(ji,jj) * r1_e2v(ji,jj) 
    609                ! zhpi will be added in interior loop 
    610                va(ji,jj,ikv) = va(ji,jj,ikv) + zvap 
    611                ! in case of 2 cell water column, need to save the pressure gradient to compute the bottom pressure   
    612                IF( mbkv(ji,jj) == ikv + 1 )   zpshpj(ji,jj) = zhpj(ji,jj,ikv)  
    613                 
    614                ! case ikv + 1 (remove the zphj term added in the interior loop and compute the one corrected for zps) 
    615                zhpjint =  zcoef0 * r1_e2v(ji,jj)                                                            & 
    616                   &    * (  e3w_n(ji  ,jj+1,ikv+1) * (  (rhd(ji,jj+1,ikv+1) + znad)                         & 
    617                   &                                   + (rhd(ji,jj+1,ikv  ) + znad) ) * tmask(ji,jj+1,ikv)  & 
    618                   &       - e3w_n(ji  ,jj  ,ikv+1) * (  (rhd(ji,jj  ,ikv+1) + znad)                         & 
    619                   &                                   + (rhd(ji,jj  ,ikv  ) + znad) ) * tmask(ji,jj  ,ikv)  ) 
    620                zhpj(ji,jj,ikv+1) =  zcoef0 * r1_e2v(ji,jj) * ge3rvi(ji,jj) - zhpjint 
    621             ENDIF 
    622          END DO 
    623       END DO 
    624  
    625 !==================================================================================      
    626579!===== Compute interior value =====================================================  
    627580!================================================================================== 
    628  
    629       DO jj = 2, jpjm1 
    630          DO ji = fs_2, fs_jpim1   ! vector opt. 
    631             DO jk = 2, jpkm1 
     581      ! interior value (2=<jk=<jpkm1) 
     582      DO jk = 2, jpkm1 
     583         DO jj = 2, jpjm1 
     584            DO ji = fs_2, fs_jpim1   ! vector opt. 
    632585               ! hydrostatic pressure gradient along s-surfaces 
    633                ! zhpi is masked for the first wet cell  (contribution already done in the upper bloc) 
    634                zhpi(ji,jj,jk) = zhpi(ji,jj,jk) + zhpi(ji,jj,jk-1)                                                     & 
    635                   &           + zcoef0 * r1_e1u(ji,jj)                                                                & 
    636                   &                    * ( e3w_n(ji+1,jj,jk) * ( (rhd(ji+1,jj,jk  ) + znad)                           & 
    637                   &                                            + (rhd(ji+1,jj,jk-1) + znad) ) * tmask(ji+1,jj,jk-1)   & 
    638                   &                      - e3w_n(ji  ,jj,jk) * ( (rhd(ji  ,jj,jk  ) + znad)                           & 
    639                   &                                            + (rhd(ji  ,jj,jk-1) + znad) ) * tmask(ji  ,jj,jk-1)   )  
     586               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
     587                  &           * (  e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk)   & 
     588                  &              - e3w_n(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad ) * wmask(ji  ,jj,jk)   ) 
     589               zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
     590                  &           * (  e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk)   & 
     591                  &              - e3w_n(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad ) * wmask(ji,jj  ,jk)   ) 
    640592               ! s-coordinate pressure gradient correction 
    641                ! corrective term, we mask this term for the first wet level beneath the ice shelf (contribution done in the upper bloc)  
    642                zuap = - zcoef0 * ( rhd    (ji+1,jj  ,jk) + rhd    (ji,jj,jk) + 2._wp * znad )                    & 
    643                   &            * ( gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk-1) 
    644                ua(ji,jj,jk) = ua(ji,jj,jk) + ( zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk) 
    645  
    646                ! hydrostatic pressure gradient along s-surfaces 
    647                ! zhpi is masked for the first wet cell  (contribution already done in the upper bloc) 
    648                zhpj(ji,jj,jk) = zhpj(ji,jj,jk) + zhpj(ji,jj,jk-1)                                                     & 
    649                   &           + zcoef0 * r1_e2v(ji,jj)                                                                & 
    650                   &                    * ( e3w_n(ji  ,jj+1,jk) * ( (rhd(ji,jj+1,jk  ) + znad)                           & 
    651                   &                                              + (rhd(ji,jj+1,jk-1) + znad) ) * tmask(ji,jj+1,jk-1)   & 
    652                   &                      - e3w_n(ji  ,jj  ,jk) * ( (rhd(ji,jj  ,jk  ) + znad)                           & 
    653                   &                                              + (rhd(ji,jj  ,jk-1) + znad) ) * tmask(ji,jj  ,jk-1)   ) 
    654                ! s-coordinate pressure gradient correction 
    655                ! corrective term, we mask this term for the first wet level beneath the ice shelf (contribution done in the upper bloc) 
    656                zvap = - zcoef0 * ( rhd    (ji  ,jj+1,jk) + rhd    (ji,jj,jk) + 2._wp * znad )                    & 
    657                   &            * ( gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk-1) 
     593               zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     594                  &           * ( gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk) ) / e1u(ji,jj) 
     595               zvap = -zcoef0 * ( rhd   (ji  ,jj+1,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     596                  &           * ( gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk) ) / e2v(ji,jj) 
    658597               ! add to the general momentum trend 
    659                va(ji,jj,jk) = va(ji,jj,jk) + ( zhpj(ji,jj,jk) + zvap ) * vmask(ji,jj,jk) 
     598               ua(ji,jj,jk) = ua(ji,jj,jk) + (zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk) 
     599               va(ji,jj,jk) = va(ji,jj,jk) + (zhpj(ji,jj,jk) + zvap) * vmask(ji,jj,jk) 
    660600            END DO 
    661601         END DO 
    662602      END DO 
    663  
    664 !==================================================================================      
    665 !===== Compute bottom cell contribution (partial cell) ============================  
    666 !================================================================================== 
    667  
    668       DO jj = 2, jpjm1 
    669          DO ji = 2, jpim1 
    670             iku = mbku(ji,jj) 
    671             ikv = mbkv(ji,jj) 
    672  
    673             IF (iku .GT. 1) THEN 
    674                ! remove old value (interior case) 
    675                zuap            = -zcoef0 * ( rhd    (ji+1,jj  ,iku) + rhd    (ji,jj,iku) + 2._wp * znad )   & 
    676                      &                   * ( gde3w_n(ji+1,jj  ,iku) - gde3w_n(ji,jj,iku) ) * r1_e1u(ji,jj) 
    677                ua(ji,jj,iku)   = ua(ji,jj,iku) - zhpi(ji,jj,iku) - zuap 
    678                ! put new value 
    679                ! -zpshpi to avoid double contribution of the partial step in the top layer  
    680                zuap            = -zcoef0 * ( aru(ji,jj) + 2._wp * znad ) * gzu(ji,jj)  * r1_e1u(ji,jj) 
    681                zhpi(ji,jj,iku) =  zhpi(ji,jj,iku-1) + zcoef0 * r1_e1u(ji,jj) * ge3ru(ji,jj) - zpshpi(ji,jj)  
    682                ua(ji,jj,iku)   =  ua(ji,jj,iku) + zhpi(ji,jj,iku) + zuap 
    683             END IF 
    684             ! v direction 
    685             IF (ikv .GT. 1) THEN 
    686                ! remove old value (interior case) 
    687                zvap            = -zcoef0 * ( rhd    (ji  ,jj+1,ikv) + rhd    (ji,jj,ikv) + 2._wp * znad )   & 
    688                      &                   * ( gde3w_n(ji  ,jj+1,ikv) - gde3w_n(ji,jj,ikv) ) * r1_e2v(ji,jj) 
    689                va(ji,jj,ikv)   = va(ji,jj,ikv) - zhpj(ji,jj,ikv) - zvap 
    690                ! put new value 
    691                ! -zpshpj to avoid double contribution of the partial step in the top layer  
    692                zvap            = -zcoef0 * ( arv(ji,jj) + 2._wp * znad ) * gzv(ji,jj) * r1_e2v(ji,jj) 
    693                zhpj(ji,jj,ikv) =  zhpj(ji,jj,ikv-1) + zcoef0 * r1_e2v(ji,jj) * ge3rv(ji,jj) - zpshpj(ji,jj)    
    694                va(ji,jj,ikv)   =  va(ji,jj,ikv) + zhpj(ji,jj,ikv) + zvap 
    695             END IF 
    696          END DO 
    697       END DO 
    698       
    699       ! set back to original density value into the ice shelf cell (maybe useless because it is masked) 
    700       rhd = zrhd 
    701       ! 
    702       CALL wrk_dealloc( jpi,jpj,2, ztstop) 
    703       CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj, zrhd) 
    704       CALL wrk_dealloc( jpi,jpj, ze3w, zp, zrhdtop_isf, zrhdtop_oce, ziceload, zdept, zpshpi, zpshpj) 
     603     ! 
     604      CALL wrk_dealloc( jpi,jpj,2  , ztstop) 
     605      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zhpj) 
     606      CALL wrk_dealloc( jpi,jpj    , zrhdtop_oce ) 
    705607      ! 
    706608   END SUBROUTINE hpg_isf 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r6060 r6069  
    9494      ! 
    9595      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    96       INTEGER  ::   iku, ikv     ! local integers 
     96      INTEGER  ::   ikt          ! local integers 
    9797      REAL(wp) ::   zue3a, zue3n, zue3b, zuf, zcoef    ! local scalars 
    9898      REAL(wp) ::   zve3a, zve3n, zve3b, zvf, z1_2dt   !   -      - 
    … …  
    220220               ! Add volume filter correction: compatibility with tracer advection scheme 
    221221               ! => time filter + conservation correction (only at the first level) 
    222                IF( nn_isf == 0) THEN   ! if no ice shelf melting 
    223                   zcoef = atfp * rdt * r1_rau0 
    224                   e3t_b(:,:,1) = e3t_b(:,:,1) - zcoef * (  emp_b(:,:) - emp(:,:) & 
    225                      &                                   - rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     222               zcoef = atfp * rdt * r1_rau0 
     223               IF ( .NOT. ln_isf ) THEN   ! if no ice shelf melting 
     224                  e3t_b(:,:,1) = e3t_b(:,:,1) - zcoef * ( emp_b(:,:) - emp(:,:) & 
     225                                 &                      - rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
    226226               ELSE                     ! if ice shelf melting 
    227                   zcoef = atfp * rdt * r1_rau0 
    228227                  DO jj = 1, jpj 
    229228                     DO ji = 1, jpi 
    230                         jk = mikt(ji,jj) 
    231                         e3t_b(ji,jj,jk) = e3t_b(ji,jj,jk) - zcoef * (  emp_b   (ji,jj) - emp   (ji,jj)  & 
    232                            &                                         - rnf_b   (ji,jj) + rnf   (ji,jj)  & 
    233                            &                                         + fwfisf_b(ji,jj) - fwfisf(ji,jj)  ) * tmask(ji,jj,jk) 
     229                        ikt = mikt(ji,jj) 
     230                        e3t_b(ji,jj,ikt) = e3t_b(ji,jj,ikt) - zcoef * (  emp_b   (ji,jj) - emp   (ji,jj)  & 
     231                           &                                           - rnf_b   (ji,jj) + rnf   (ji,jj)  & 
     232                           &                                           + fwfisf_b(ji,jj) - fwfisf(ji,jj)  ) * tmask(ji,jj,ikt) 
    234233                     END DO 
    235234                  END DO 
    … …  
    318317            hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk) 
    319318         END DO 
    320 !!gm don't understand the use of umask_i .... 
    321          r1_hu_b(:,:) = umask_i(:,:) / ( hu_b(:,:) + 1._wp - umask_i(:,:) ) 
    322          r1_hv_b(:,:) = vmask_i(:,:) / ( hv_b(:,:) + 1._wp - vmask_i(:,:) ) 
     319         r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) ) 
     320         r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) ) 
    323321      ENDIF 
    324322      ! 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r6060 r6069  
    211211      IF( ioptio  > 1 )   CALL ctl_stop( 'Choose only one surface pressure gradient scheme' ) 
    212212      IF( ioptio == 0 )   CALL ctl_warn( 'NO surface pressure gradient trend in momentum Eqs.' ) 
     213      IF( ln_dynspg_exp .AND. ln_isfcav )   & 
     214           &   CALL ctl_stop( ' dynspg_exp not tested with ice shelf cavity ' ) 
    213215      ! 
    214216      IF( ln_dynspg_ts .AND. ln_isfcav )   CALL ctl_stop( ' dynspg_ts not tested with ice shelf cavity ' ) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r6060 r6069  
    4646   USE wrk_nemo        ! Memory Allocation 
    4747   USE timing          ! Timing     
     48   USE diatmb          ! Top,middle,bottom output 
    4849#if defined key_agrif 
    4950   USE agrif_opa_interp ! agrif 
    … …  
    5253   USE asminc          ! Assimilation increment 
    5354#endif 
     55 
    5456 
    5557   IMPLICIT NONE 
    … …  
    132134      INTEGER, INTENT(in)  ::   kt   ! ocean time-step index 
    133135      ! 
    134       LOGICAL  ::   ll_fw_start      ! if true, forward integration  
    135       LOGICAL  ::   ll_init          ! if true, special startup of 2d equations 
    136       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    137       INTEGER  ::   ikbu, ikbv, noffset        ! local integers 
    138       REAL(wp) ::   zraur, z1_2dt_b, z2dt_bf   ! local scalars 
    139       REAL(wp) ::   zx1, zy1, zx2, zy2         !   -      - 
    140       REAL(wp) ::   z1_12, z1_8, z1_4, z1_2    !   -      - 
    141       REAL(wp) ::   zu_spg, zv_spg             !   -      - 
    142       REAL(wp) ::   zhura, zhvra               !   -      - 
    143       REAL(wp) ::   za0, za1, za2, za3         !   -      - 
     136      LOGICAL  ::   ll_fw_start        ! if true, forward integration  
     137      LOGICAL  ::   ll_init             ! if true, special startup of 2d equations 
     138      INTEGER  ::   ji, jj, jk, jn        ! dummy loop indices 
     139      INTEGER  ::   ikbu, ikbv, noffset      ! local integers 
     140      INTEGER  ::   iktu, iktv               ! local integers 
     141      REAL(wp) ::   zmdi 
     142      REAL(wp) ::   zraur, z1_2dt_b, z2dt_bf    ! local scalars 
     143      REAL(wp) ::   zx1, zy1, zx2, zy2          !   -      - 
     144      REAL(wp) ::   z1_12, z1_8, z1_4, z1_2  !   -      - 
     145      REAL(wp) ::   zu_spg, zv_spg              !   -      - 
     146      REAL(wp) ::   zhura, zhvra          !   -      - 
     147      REAL(wp) ::   za0, za1, za2, za3    !   -      - 
    144148      ! 
    145149      REAL(wp), POINTER, DIMENSION(:,:) :: zsshp2_e 
    … …  
    161165      CALL wrk_alloc( jpi,jpj,   zhf ) 
    162166      ! 
    163       z1_12 = 1._wp / 12._wp                 !* Local constant initialization 
     167      zmdi=1.e+20                               !  missing data indicator for masking 
     168      !                                         !* Local constant initialization 
     169      z1_12 = 1._wp / 12._wp  
    164170      z1_8  = 0.125_wp                                    
    165171      z1_4  = 0.25_wp 
    … …  
    372378      DO jj = 2, jpjm1                          ! Remove coriolis term (and possibly spg) from barotropic trend 
    373379         DO ji = fs_2, fs_jpim1 
    374              zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * umask(ji,jj,1) 
    375              zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * vmask(ji,jj,1) 
     380             zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 
     381             zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 
    376382          END DO 
    377383      END DO  
    … …  
    402408      zv_frc(:,:) = zv_frc(:,:) + r1_hv_n(:,:) * bfrva(:,:) * zwy(:,:) 
    403409      !        
    404       IF( ln_bt_fw ) THEN                        ! Add wind forcing 
     410      !                                         ! Add top stress contribution from baroclinic velocities:       
     411      IF (ln_bt_fw) THEN 
     412         DO jj = 2, jpjm1 
     413            DO ji = fs_2, fs_jpim1   ! vector opt. 
     414               iktu = miku(ji,jj) 
     415               iktv = mikv(ji,jj) 
     416               zwx(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) ! NOW top baroclinic velocities 
     417               zwy(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 
     418            END DO 
     419         END DO 
     420      ELSE 
     421         DO jj = 2, jpjm1 
     422            DO ji = fs_2, fs_jpim1   ! vector opt. 
     423               iktu = miku(ji,jj) 
     424               iktv = mikv(ji,jj) 
     425               zwx(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) ! BEFORE top baroclinic velocities 
     426               zwy(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 
     427            END DO 
     428         END DO 
     429      ENDIF 
     430      ! 
     431      ! Note that the "unclipped" top friction parameter is used even with explicit drag 
     432      zu_frc(:,:) = zu_frc(:,:) + r1_hu_n(:,:) * tfrua(:,:) * zwx(:,:) 
     433      zv_frc(:,:) = zv_frc(:,:) + r1_hv_n(:,:) * tfrva(:,:) * zwy(:,:) 
     434      !        
     435      IF (ln_bt_fw) THEN                        ! Add wind forcing 
    405436         zu_frc(:,:) =  zu_frc(:,:) + zraur * utau(:,:) * r1_hu_n(:,:) 
    406437         zv_frc(:,:) =  zv_frc(:,:) + zraur * vtau(:,:) * r1_hv_n(:,:) 
    … …  
    532563            DO jj = 2, jpjm1                                    ! Sea Surface Height at u- & v-points 
    533564               DO ji = 2, fs_jpim1   ! Vector opt. 
    534                   zwx(ji,jj) = z1_2 * umask(ji,jj,1)  * r1_e1e2u(ji,jj)     & 
     565                  zwx(ji,jj) = z1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj)     & 
    535566                     &              * ( e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    536567                     &              +   e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 
    537                   zwy(ji,jj) = z1_2 * vmask(ji,jj,1)  * r1_e1e2v(ji,jj)     & 
     568                  zwy(ji,jj) = z1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj)     & 
    538569                     &              * ( e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    539570                     &              +   e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 
    … …  
    594625            END DO 
    595626         END DO 
    596          ssha_e(:,:) = (  sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) )  ) * tmask(:,:,1) 
     627         ssha_e(:,:) = (  sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) )  ) * ssmask(:,:) 
    597628         CALL lbc_lnk( ssha_e, 'T',  1._wp ) 
    598629 
    … …  
    609640            DO jj = 2, jpjm1 
    610641               DO ji = 2, jpim1      ! NO Vector Opt. 
    611                   zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1)  * r1_e1e2u(ji,jj)  & 
    612                      &              * ( e1e2t(ji  ,jj  ) * ssha_e(ji  ,jj  ) & 
    613                      &              +   e1e2t(ji+1,jj  ) * ssha_e(ji+1,jj  ) ) 
    614                   zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1)  * r1_e1e2v(ji,jj)  & 
    615                      &              * ( e1e2t(ji  ,jj  ) * ssha_e(ji  ,jj  ) & 
    616                      &              +   e1e2t(ji  ,jj+1) * ssha_e(ji  ,jj+1) ) 
     642                  zsshu_a(ji,jj) = z1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
     643                     &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
     644                     &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) ) 
     645                  zsshv_a(ji,jj) = z1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    & 
     646                     &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
     647                     &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) ) 
    617648               END DO 
    618649            END DO 
    … …  
    647678            DO jj = 2, jpjm1                             
    648679               DO ji = 2, jpim1 
    649                   zx1 = z1_2 * umask(ji  ,jj,1) *  r1_e1e2u(ji  ,jj)    & 
     680                  zx1 = z1_2 * ssumask(ji  ,jj) *  r1_e1e2u(ji  ,jj)    & 
    650681                     &      * ( e1e2t(ji  ,jj  ) * zsshp2_e(ji  ,jj)    & 
    651682                     &      +   e1e2t(ji+1,jj  ) * zsshp2_e(ji+1,jj  ) ) 
    652                   zy1 = z1_2 * vmask(ji  ,jj,1) *  r1_e1e2v(ji  ,jj  )  & 
     683                  zy1 = z1_2 * ssvmask(ji  ,jj) *  r1_e1e2v(ji  ,jj  )  & 
    653684                     &       * ( e1e2t(ji ,jj  ) * zsshp2_e(ji  ,jj  )  & 
    654685                     &       +   e1e2t(ji ,jj+1) * zsshp2_e(ji  ,jj+1) ) 
    … …  
    722753         zv_trd(:,:) = zv_trd(:,:) + bfrva(:,:) * vn_e(:,:) * hvr_e(:,:) 
    723754         ! 
     755         ! Add top stresses: 
     756         zu_trd(:,:) = zu_trd(:,:) + tfrua(:,:) * un_e(:,:) * hur_e(:,:) 
     757         zv_trd(:,:) = zv_trd(:,:) + tfrva(:,:) * vn_e(:,:) * hvr_e(:,:) 
     758         ! 
    724759         ! Surface pressure trend: 
    725760         DO jj = 2, jpjm1 
    … …  
    737772            DO jj = 2, jpjm1 
    738773               DO ji = fs_2, fs_jpim1   ! vector opt. 
    739                   ua_e(ji,jj) = (                                 un_e(ji,jj)    &  
    740                      &            + rdtbt * (                      zwx(ji,jj)    & 
    741                      &                                        + zu_trd(ji,jj)    & 
    742                      &                                        + zu_frc(ji,jj) )  ) * umask(ji,jj,1) 
    743                      ! 
    744                   va_e(ji,jj) = (                                 vn_e(ji,jj)    & 
    745                      &            + rdtbt * (                      zwy(ji,jj)    & 
    746                      &                                        + zv_trd(ji,jj)    & 
    747                      &                                        + zv_frc(ji,jj) )  ) * vmask(ji,jj,1) 
     774                  ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
     775                            &     + rdtbt * (                      zwx(ji,jj)   & 
     776                            &                                 + zu_trd(ji,jj)   & 
     777                            &                                 + zu_frc(ji,jj) ) &  
     778                            &   ) * ssumask(ji,jj) 
     779 
     780                  va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
     781                            &     + rdtbt * (                      zwy(ji,jj)   & 
     782                            &                                 + zv_trd(ji,jj)   & 
     783                            &                                 + zv_frc(ji,jj) ) & 
     784                            &   ) * ssvmask(ji,jj) 
    748785               END DO 
    749786            END DO 
    … …  
    752789            DO jj = 2, jpjm1 
    753790               DO ji = fs_2, fs_jpim1   ! vector opt. 
    754                   zhura = umask(ji,jj,1) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - umask(ji,jj,1) ) 
    755                   zhvra = vmask(ji,jj,1) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - vmask(ji,jj,1) ) 
    756                   ! 
    757                   ua_e(ji,jj) = (                hu_e(ji,jj)  *   un_e(ji,jj)    &  
    758                      &            + rdtbt * ( zhust_e(ji,jj)  *    zwx(ji,jj)    &  
    759                      &                      + zhup2_e(ji,jj)  * zu_trd(ji,jj)    & 
    760                      &                      +    hu_n(ji,jj)  * zu_frc(ji,jj) )  ) * zhura 
    761                      ! 
    762                   va_e(ji,jj) = (                hv_e(ji,jj)  *   vn_e(ji,jj)    & 
    763                      &            + rdtbt * ( zhvst_e(ji,jj)  *    zwy(ji,jj)    & 
    764                      &                      + zhvp2_e(ji,jj)  * zv_trd(ji,jj)    & 
    765                      &                      +    hv_n(ji,jj)  * zv_frc(ji,jj) )  ) * zhvra 
     791                  zhura = ssumask(ji,jj)/(hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj)) 
     792                  zhvra = ssvmask(ji,jj)/(hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj)) 
     793 
     794                  ua_e(ji,jj) = (                hu_e(ji,jj)  *   un_e(ji,jj)   &  
     795                            &     + rdtbt * ( zhust_e(ji,jj)  *    zwx(ji,jj)   &  
     796                            &               + zhup2_e(ji,jj)  * zu_trd(ji,jj)   & 
     797                            &               +      hu(ji,jj)  * zu_frc(ji,jj) ) & 
     798                            &   ) * zhura 
     799 
     800                  va_e(ji,jj) = (                hv_e(ji,jj)  *   vn_e(ji,jj)   & 
     801                            &     + rdtbt * ( zhvst_e(ji,jj)  *    zwy(ji,jj)   & 
     802                            &               + zhvp2_e(ji,jj)  * zv_trd(ji,jj)   & 
     803                            &               +      hv(ji,jj)  * zv_frc(ji,jj) ) & 
     804                            &   ) * zhvra 
    766805               END DO 
    767806            END DO 
    … …  
    771810            hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 
    772811            hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 
    773             hur_e(:,:) = umask(:,:,1) / ( hu_e(:,:) + 1._wp - umask(:,:,1) ) 
    774             hvr_e(:,:) = vmask(:,:,1) / ( hv_e(:,:) + 1._wp - vmask(:,:,1) ) 
     812            hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) ) 
     813            hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) ) 
    775814            ! 
    776815         ENDIF 
    … …  
    805844            ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:)  
    806845            va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:)  
    807          ELSE                                ! Sum transports 
     846         ELSE                                              ! Sum transports 
    808847            ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) * hu_e (:,:) 
    809848            va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) * hv_e (:,:) 
    … …  
    859898         END DO 
    860899         ! Save barotropic velocities not transport: 
    861          ua_b(:,:) =  ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - umask(:,:,1) ) 
    862          va_b(:,:) =  va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - vmask(:,:,1) ) 
     900         ua_b(:,:) =  ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) 
     901         va_b(:,:) =  va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) 
    863902      ENDIF 
    864903      ! 
    … …  
    898937      CALL wrk_dealloc( jpi,jpj,   zhf ) 
    899938      ! 
     939      IF ( ln_diatmb ) THEN 
     940         CALL iom_put( "baro_u" , un_b*umask(:,:,1)+zmdi*(1-umask(:,:,1 ) ) )  ! Barotropic  U Velocity 
     941         CALL iom_put( "baro_v" , vn_b*vmask(:,:,1)+zmdi*(1-vmask(:,:,1 ) ) )  ! Barotropic  V Velocity 
     942      ENDIF 
    900943      IF( nn_timing == 1 )  CALL timing_stop('dyn_spg_ts') 
    901944      ! 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90

    r6060 r6069  
    8989         DO jj = 2, jpjm1                 ! vertical momentum advection at w-point 
    9090            DO ji = fs_2, fs_jpim1        ! vector opt. 
    91                zwuw(ji,jj,jk) = ( zww(ji+1,jj  ) + zww(ji,jj) ) * ( un(ji,jj,jk-1)-un(ji,jj,jk) ) 
    92                zwvw(ji,jj,jk) = ( zww(ji  ,jj+1) + zww(ji,jj) ) * ( vn(ji,jj,jk-1)-vn(ji,jj,jk) ) 
     91               zwuw(ji,jj,jk) = ( zww(ji+1,jj  ) + zww(ji,jj) ) * ( un(ji,jj,jk-1) - un(ji,jj,jk) ) 
     92               zwvw(ji,jj,jk) = ( zww(ji  ,jj+1) + zww(ji,jj) ) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) ) 
    9393            END DO   
    9494         END DO    

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90

    r5341 r6069  
    1212   !!            -    !                            Currently needs a fixed processor 
    1313   !!            -    !                            layout between restarts 
     14   !!            -    !  2015-11  Dave Storkey     Convert icb_rst_read to use IOM so can 
     15   !!                                              read single restart files 
    1416   !!---------------------------------------------------------------------- 
    1517   !!---------------------------------------------------------------------- 
    … …  
    2224   USE lib_mpp        ! NEMO MPI library, lk_mpp in particular 
    2325   USE netcdf         ! netcdf routines for IO 
     26   USE iom 
    2427   USE icb_oce        ! define iceberg arrays 
    2528   USE icbutl         ! iceberg utility routines 
    … …  
    5760      INTEGER                      ::   idim, ivar, iatt 
    5861      INTEGER                      ::   jn, iunlim_dim, ibergs_in_file 
    59       INTEGER                      ::   iclass 
    60       INTEGER, DIMENSION(1)        ::   istrt, ilngth, idata 
    61       INTEGER, DIMENSION(2)        ::   istrt2, ilngth2 
    62       INTEGER, DIMENSION(nkounts)  ::   idata2 
    63       REAL(wp), DIMENSION(1)       ::   zdata                                         ! need 1d array to read in with 
    64                                                                                             ! start and count arrays 
     62      INTEGER                      ::   ii,ij,iclass 
     63      REAL(wp), DIMENSION(nkounts) ::   zdata       
    6564      LOGICAL                      ::   ll_found_restart 
    6665      CHARACTER(len=256)           ::   cl_path 
    … …  
    7170      !!---------------------------------------------------------------------- 
    7271 
    73       ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts.  
     72      ! Find a restart file. Assume iceberg restarts in same directory as ocean restarts 
     73      ! and are called TRIM(cn_ocerst)//'_icebergs' 
    7474      cl_path = TRIM(cn_ocerst_indir) 
    7575      IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' 
    76       cl_filename = ' ' 
    77       IF ( lk_mpp ) THEN 
    78          cl_filename = ' ' 
    79          WRITE( cl_filename, '("restart_icebergs_",I4.4,".nc")' ) narea-1 
    80          INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 
    81       ELSE 
    82          cl_filename = 'restart_icebergs.nc' 
    83          INQUIRE( file=TRIM(cl_path)//TRIM(cl_filename), exist=ll_found_restart ) 
    84       ENDIF 
    85  
    86       IF ( .NOT. ll_found_restart) THEN                     ! only do the following if a file was found 
    87          CALL ctl_stop('icebergs: no restart file found') 
    88       ENDIF 
    89  
    90       IF (nn_verbose_level >= 0 .AND. lwp)  & 
    91          WRITE(numout,'(2a)') 'icebergs, read_restart_bergs: found restart file = ',TRIM(cl_path)//TRIM(cl_filename) 
    92  
    93       nret = NF90_OPEN(TRIM(cl_path)//TRIM(cl_filename), NF90_NOWRITE, ncid) 
    94       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_open failed') 
    95  
    96       nret = nf90_inquire(ncid, idim, ivar, iatt, iunlim_dim) 
    97       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_inquire failed') 
    98  
    99       IF( iunlim_dim .NE. -1) THEN 
    100  
    101          nret = nf90_inquire_dimension(ncid, iunlim_dim, cl_dname, ibergs_in_file) 
    102          IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart_bergs: nf_inq_dimlen failed') 
    103  
    104          nret = NF90_INQ_VARID(ncid, 'number', numberid) 
    105          nret = NF90_INQ_VARID(ncid, 'mass_scaling', nscaling_id) 
    106          nret = NF90_INQ_VARID(ncid, 'xi', nxid) 
    107          nret = NF90_INQ_VARID(ncid, 'yj', nyid) 
    108          nret = NF90_INQ_VARID(ncid, 'lon', nlonid) 
    109          nret = NF90_INQ_VARID(ncid, 'lat', nlatid) 
    110          nret = NF90_INQ_VARID(ncid, 'uvel', nuvelid) 
    111          nret = NF90_INQ_VARID(ncid, 'vvel', nvvelid) 
    112          nret = NF90_INQ_VARID(ncid, 'mass', nmassid) 
    113          nret = NF90_INQ_VARID(ncid, 'thickness', nthicknessid) 
    114          nret = NF90_INQ_VARID(ncid, 'width', nwidthid) 
    115          nret = NF90_INQ_VARID(ncid, 'length', nlengthid) 
    116          nret = NF90_INQ_VARID(ncid, 'year', nyearid) 
    117          nret = NF90_INQ_VARID(ncid, 'day', ndayid) 
    118          nret = NF90_INQ_VARID(ncid, 'mass_of_bits', nmass_of_bits_id) 
    119          nret = NF90_INQ_VARID(ncid, 'heat_density', nheat_density_id) 
    120  
    121          ilngth(1) = 1 
    122          istrt2(1) = 1 
    123          ilngth2(1) = nkounts 
    124          ilngth2(2) = 1 
    125          DO jn=1, ibergs_in_file 
    126  
    127             istrt(1) = jn 
    128             istrt2(2) = jn 
    129  
    130             nret = NF90_GET_VAR(ncid, numberid, idata2, istrt2, ilngth2 ) 
    131             localberg%number(:) = idata2(:) 
    132  
    133             nret = NF90_GET_VAR(ncid, nscaling_id, zdata, istrt, ilngth ) 
    134             localberg%mass_scaling = zdata(1) 
    135  
    136             nret = NF90_GET_VAR(ncid, nlonid, zdata, istrt, ilngth) 
    137             localpt%lon = zdata(1) 
    138             nret = NF90_GET_VAR(ncid, nlatid, zdata, istrt, ilngth) 
    139             localpt%lat = zdata(1) 
    140             IF (nn_verbose_level >= 2 .AND. lwp) THEN 
    141                WRITE(numout,'(a,i5,a,2f10.4,a,i5)') 'icebergs, read_restart_bergs: berg ',jn,' is at ', & 
    142                                               localpt%lon,localpt%lat,' on PE ',narea-1 
     76      cl_filename = TRIM(cn_ocerst_in)//'_icebergs' 
     77      CALL iom_open( TRIM(cl_path)//cl_filename, ncid ) 
     78 
     79      IF( iom_file(ncid)%iduld .GE. 0) THEN 
     80 
     81         ibergs_in_file = iom_file(ncid)%lenuld 
     82         DO jn = 1,ibergs_in_file 
     83 
     84            ! iom_get treats the unlimited dimension as time. Here the unlimited dimension  
     85            ! is the iceberg index, but we can still use the ktime keyword to get the iceberg we want.  
     86 
     87            CALL iom_get( ncid, 'xi'     ,localpt%xi  , ktime=jn ) 
     88            CALL iom_get( ncid, 'yj'     ,localpt%yj  , ktime=jn ) 
     89 
     90            ii = INT( localpt%xi + 0.5 ) 
     91            ij = INT( localpt%yj + 0.5 ) 
     92            ! Only proceed if this iceberg is on the local processor (excluding halos). 
     93            IF ( ii .GE. nldi+nimpp-1 .AND. ii .LE. nlei+nimpp-1 .AND. & 
     94           &     ij .GE. nldj+njmpp-1 .AND. ij .LE. nlej+njmpp-1 ) THEN            
     95 
     96               CALL iom_get( ncid, jpdom_unknown, 'number'       , (/zdata(:)/) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) ) 
     97               localberg%number(:) = INT(zdata(:)) 
     98               CALL iom_get( ncid, 'mass_scaling' , localberg%mass_scaling, ktime=jn ) 
     99               CALL iom_get( ncid, 'lon'          , localpt%lon           , ktime=jn ) 
     100               CALL iom_get( ncid, 'lat'          , localpt%lat           , ktime=jn ) 
     101               CALL iom_get( ncid, 'uvel'         , localpt%uvel          , ktime=jn ) 
     102               CALL iom_get( ncid, 'vvel'         , localpt%vvel          , ktime=jn ) 
     103               CALL iom_get( ncid, 'mass'         , localpt%mass          , ktime=jn ) 
     104               CALL iom_get( ncid, 'thickness'    , localpt%thickness     , ktime=jn ) 
     105               CALL iom_get( ncid, 'width'        , localpt%width         , ktime=jn ) 
     106               CALL iom_get( ncid, 'length'       , localpt%length        , ktime=jn ) 
     107               CALL iom_get( ncid, 'year'         , zdata(1)              , ktime=jn ) 
     108               localpt%year = INT(zdata(1)) 
     109               CALL iom_get( ncid, 'day'          , localpt%day           , ktime=jn ) 
     110               CALL iom_get( ncid, 'mass_of_bits' , localpt%mass_of_bits  , ktime=jn ) 
     111               CALL iom_get( ncid, 'heat_density' , localpt%heat_density  , ktime=jn ) 
     112 
     113               ! 
     114               CALL icb_utl_add( localberg, localpt ) 
     115 
    143116            ENDIF 
    144             nret = NF90_GET_VAR(ncid, nxid, zdata, istrt, ilngth) 
    145             localpt%xi = zdata(1) 
    146             nret = NF90_GET_VAR(ncid, nyid, zdata, istrt, ilngth) 
    147             localpt%yj = zdata(1) 
    148             nret = NF90_GET_VAR(ncid, nuvelid, zdata, istrt, ilngth ) 
    149             localpt%uvel = zdata(1) 
    150             nret = NF90_GET_VAR(ncid, nvvelid, zdata, istrt, ilngth ) 
    151             localpt%vvel = zdata(1) 
    152             nret = NF90_GET_VAR(ncid, nmassid, zdata, istrt, ilngth ) 
    153             localpt%mass = zdata(1) 
    154             nret = NF90_GET_VAR(ncid, nthicknessid, zdata, istrt, ilngth ) 
    155             localpt%thickness = zdata(1) 
    156             nret = NF90_GET_VAR(ncid, nwidthid, zdata, istrt, ilngth ) 
    157             localpt%width = zdata(1) 
    158             nret = NF90_GET_VAR(ncid, nlengthid, zdata, istrt, ilngth ) 
    159             localpt%length = zdata(1) 
    160             nret = NF90_GET_VAR(ncid, nyearid, idata, istrt, ilngth ) 
    161             localpt%year = idata(1) 
    162             nret = NF90_GET_VAR(ncid, ndayid, zdata, istrt, ilngth ) 
    163             localpt%day = zdata(1) 
    164             nret = NF90_GET_VAR(ncid, nmass_of_bits_id, zdata, istrt, ilngth ) 
    165             localpt%mass_of_bits = zdata(1) 
    166             nret = NF90_GET_VAR(ncid, nheat_density_id, zdata, istrt, ilngth ) 
    167             localpt%heat_density = zdata(1) 
    168             ! 
    169             CALL icb_utl_add( localberg, localpt ) 
     117 
    170118         END DO 
    171          ! 
    172       ENDIF 
    173  
    174       nret = NF90_INQ_DIMID( ncid, 'c', nc_dim ) 
    175       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart: nf_inq_dimid c failed') 
    176  
    177       nret = NF90_INQUIRE_DIMENSION( ncid, nc_dim, cl_dname, iclass ) 
    178       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart: nf_inquire_dimension failed') 
    179  
    180       nret = NF90_INQ_VARID(ncid, 'kount'       , nkountid) 
    181       nret = NF90_INQ_VARID(ncid, 'calving'     , ncalvid) 
    182       nret = NF90_INQ_VARID(ncid, 'calving_hflx', ncalvhid) 
    183       nret = NF90_INQ_VARID(ncid, 'stored_ice'  , nsiceid) 
    184       nret = NF90_INQ_VARID(ncid, 'stored_heat' , nsheatid) 
    185  
    186       nstrt3(1) = 1 
    187       nstrt3(2) = 1 
    188       nlngth3(1) = jpi 
    189       nlngth3(2) = jpj 
    190       nlngth3(3) = 1 
    191  
    192       DO jn = 1, iclass 
    193          nstrt3(3) = jn 
    194          nret      = NF90_GET_VAR( ncid, nsiceid , griddata, nstrt3, nlngth3 ) 
    195          berg_grid%stored_ice(:,:,jn) = griddata(:,:,1) 
    196       END DO 
    197  
    198       nret = NF90_GET_VAR( ncid, ncalvid , src_calving          (:,:) ) 
    199       nret = NF90_GET_VAR( ncid, ncalvhid, src_calving_hflx     (:,:) ) 
    200       nret = NF90_GET_VAR( ncid, nsheatid, berg_grid%stored_heat(:,:) ) 
    201       nret = NF90_GET_VAR( ncid, nkountid, idata2(:) ) 
    202       num_bergs(:) = idata2(:) 
    203  
    204       ! Finish up 
    205       nret = NF90_CLOSE(ncid) 
    206       IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, read_restart: nf_close failed') 
     119 
     120      ENDIF  
     121 
     122      ! Gridded variables 
     123      CALL iom_get( ncid, jpdom_autoglo,    'calving'     , src_calving  ) 
     124      CALL iom_get( ncid, jpdom_autoglo,    'calving_hflx', src_calving_hflx  ) 
     125      CALL iom_get( ncid, jpdom_autoglo,    'stored_heat' , berg_grid%stored_heat  ) 
     126      CALL iom_get( ncid, jpdom_autoglo_xy, 'stored_ice'  , berg_grid%stored_ice, kstart=(/1,1,1/), kcount=(/1,1,nclasses/) ) 
     127       
     128      CALL iom_get( ncid, jpdom_unknown, 'kount' , (/zdata(:)/) ) 
     129      num_bergs(:) = INT(zdata(:)) 
    207130 
    208131      ! Sanity check 
    … …  
    211134         WRITE(numout,'(2(a,i5))') 'icebergs, read_restart_bergs: # bergs =',jn,' on PE',narea-1 
    212135      IF( lk_mpp ) THEN 
    213          CALL mpp_sum(ibergs_in_file) 
     136         ! Only mpp_sum ibergs_in_file if we are reading from multiple restart files.  
     137         IF( INDEX(iom_file(ncid)%name,'icebergs.nc' ) .EQ. 0 ) CALL mpp_sum(ibergs_in_file) 
    214138         CALL mpp_sum(jn) 
    215139      ENDIF 
    216140      IF(lwp)   WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, read_restart_bergs: there were',ibergs_in_file,   & 
    217141         &                                    ' bergs in the restart file and', jn,' bergs have been read' 
     142      ! 
     143      ! Finish up 
     144      CALL iom_close( ncid ) 
    218145      ! 
    219146      IF( lwp .and. nn_verbose_level >= 0)  WRITE(numout,'(a)') 'icebergs, read_restart_bergs: completed' 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r6060 r6069  
    3636   INTEGER       ::   nn_itend         !: index of the last time step 
    3737   INTEGER       ::   nn_date0         !: initial calendar date aammjj 
     38   INTEGER       ::   nn_time0         !: initial time of day in hhmm 
    3839   INTEGER       ::   nn_leapy         !: Leap year calendar flag (0/1 or 30) 
    3940   INTEGER       ::   nn_istate        !: initial state output flag (0/1) 
    … …  
    9899   LOGICAL ::   ln_ctl       !: run control for debugging 
    99100   INTEGER ::   nn_timing    !: run control for timing 
     101   INTEGER ::   nn_diacfl    !: flag whether to create CFL diagnostics 
    100102   INTEGER ::   nn_print     !: level of print (0 no print) 
    101103   INTEGER ::   nn_ictls     !: Start i indice for the SUM control 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r5836 r6069  
    673673      CHARACTER(LEN=256)             ::   clname      ! file name 
    674674      CHARACTER(LEN=1)               ::   clrankpv, cldmspc      !  
     675      LOGICAL                        ::   ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. 
    675676      !--------------------------------------------------------------------- 
    676677      ! 
    … …  
    685686      IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 
    686687      IF( PRESENT(kstart) .AND. (.NOT. PRESENT(kcount)) ) CALL ctl_stop(trim(clinfo), 'kstart present needs kcount present') 
    687       IF( PRESENT(kstart) .AND. idom /= jpdom_unknown   ) CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown') 
     688      IF( PRESENT(kstart) .AND. idom /= jpdom_unknown .AND.  idom /= jpdom_autoglo_xy  ) & 
     689     &           CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy') 
    688690 
    689691      luse_jattr = .false. 
    … …  
    718720         ! update idom definition... 
    719721         ! Identify the domain in case of jpdom_auto(glo/dta) definition 
     722         IF( idom == jpdom_autoglo_xy ) THEN 
     723            ll_depth_spec = .TRUE. 
     724            idom = jpdom_autoglo 
     725         ELSE 
     726            ll_depth_spec = .FALSE. 
     727         ENDIF 
    720728         IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN             
    721729            IF( idom == jpdom_autoglo ) THEN   ;   idom = jpdom_global  
    … …  
    771779         istart(idmspc+1) = itime 
    772780 
    773          IF(              PRESENT(kstart)      ) THEN ; istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc) 
     781         IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN ; istart(1:idmspc) = kstart(1:idmspc) ; icnt(1:idmspc) = kcount(1:idmspc) 
    774782         ELSE 
    775             IF(           idom == jpdom_unknown ) THEN                                       ; icnt(1:idmspc) = idimsz(1:idmspc) 
     783            IF(           idom == jpdom_unknown ) THEN                                                ; icnt(1:idmspc) = idimsz(1:idmspc) 
    776784            ELSE  
    777785               IF( .NOT. PRESENT(pv_r1d) ) THEN   !   not a 1D array 
    … …  
    796804                  ENDIF 
    797805                  IF( PRESENT(pv_r3d) ) THEN 
    798                      IF( idom == jpdom_data ) THEN   ; icnt(3) = jpkdta 
    799                      ELSE                            ; icnt(3) = jpk 
     806                     IF( idom == jpdom_data ) THEN                                  ; icnt(3) = jpkdta 
     807                     ELSE IF( ll_depth_spec .AND. PRESENT(kstart) ) THEN            ; istart(3) = kstart(3); icnt(3) = kcount(3) 
     808                     ELSE                                                           ; icnt(3) = jpk 
    800809                     ENDIF 
    801810                  ENDIF 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/IOM/iom_def.F90

    r4205 r6069  
    99   !!--------------------------------------------------------------------------------- 
    1010   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    11    !! $Id$  
     11   !! $Id$ 
    1212   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    1313   !!--------------------------------------------------------------------------------- 
    … …  
    2626   INTEGER, PARAMETER, PUBLIC ::   jpdom_unknown       = 7   !: No dimension checking 
    2727   INTEGER, PARAMETER, PUBLIC ::   jpdom_autoglo       = 8   !:  
    28    INTEGER, PARAMETER, PUBLIC ::   jpdom_autodta       = 9   !:  
     28   INTEGER, PARAMETER, PUBLIC ::   jpdom_autoglo_xy    = 9   !: Automatically set horizontal dimensions only 
     29   INTEGER, PARAMETER, PUBLIC ::   jpdom_autodta       = 10  !:  
    2930 
    3031   INTEGER, PARAMETER, PUBLIC ::   jpioipsl    = 100      !: Use ioipsl (fliocom only) library 
    … …  
    5758      INTEGER                                   ::   nvars    !: number of identified varibles in the file 
    5859      INTEGER                                   ::   iduld    !: id of the unlimited dimension 
     60      INTEGER                                   ::   lenuld   !: length of the unlimited dimension (number of records in file) 
    5961      INTEGER                                   ::   irec     !: writing record position   
    6062      CHARACTER(LEN=32)                         ::   uldname  !: name of the unlimited dimension 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r5341 r6069  
    154154         CALL iom_nf90_check(NF90_Inquire(if90id, unlimitedDimId = iom_file(kiomid)%iduld), clinfo) 
    155155         IF ( iom_file(kiomid)%iduld .GE. 0 ) THEN 
    156            CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld,   & 
    157         &                                               name = iom_file(kiomid)%uldname), clinfo) 
     156           CALL iom_nf90_check(NF90_Inquire_Dimension(if90id, iom_file(kiomid)%iduld,     &  
     157        &                                               name = iom_file(kiomid)%uldname,  & 
     158        &                                               len  = iom_file(kiomid)%lenuld ), clinfo ) 
    158159         ENDIF 
    159160         IF(lwp) WRITE(numout,*) '                   ---> '//TRIM(cdname)//' OK' 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r6060 r6069  
    2727   USE in_out_manager  ! I/O manager 
    2828   USE iom             ! I/O module 
    29  
     29   USE diurnal_bulk 
     30    
    3031   IMPLICIT NONE 
    3132   PRIVATE 
    … …  
    127128                     CALL iom_rstput( kt, nitrst, numrow, 'rdt'    , rdt       )   ! dynamics time step 
    128129                     CALL iom_rstput( kt, nitrst, numrow, 'rdttra1', rdttra(1) )   ! surface tracer time step 
    129  
     130      IF ( .NOT. ln_diurnal_only ) THEN 
    130131                     CALL iom_rstput( kt, nitrst, numrow, 'ub'     , ub        )     ! before fields 
    131132                     CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vb        ) 
    … …  
    140141                     CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , sshn      ) 
    141142                     CALL iom_rstput( kt, nitrst, numrow, 'rhop'   , rhop      ) 
     143 
     144                  ! extra variable needed for the ice sheet coupling 
     145                  IF ( ln_iscpl ) THEN  
     146                     CALL iom_rstput( kt, nitrst, numrow, 'tmask'  , tmask     ) ! need to extrapolate T/S 
     147                     CALL iom_rstput( kt, nitrst, numrow, 'umask'  , umask     ) ! need to correct barotropic velocity 
     148                     CALL iom_rstput( kt, nitrst, numrow, 'vmask'  , vmask     ) ! need to correct barotropic velocity 
     149                     CALL iom_rstput( kt, nitrst, numrow, 'smask'  , ssmask    ) ! need to correct barotropic velocity 
     150                     CALL iom_rstput( kt, nitrst, numrow, 'fse3t_n', fse3t_n(:,:,:) )   ! need to compute temperature correction 
     151                     CALL iom_rstput( kt, nitrst, numrow, 'fse3u_n', fse3u_n(:,:,:) )   ! need to compute bt conservation 
     152                     CALL iom_rstput( kt, nitrst, numrow, 'fse3v_n', fse3v_n(:,:,:) )   ! need to compute bt conservation 
     153                     CALL iom_rstput( kt, nitrst, numrow, 'fsdepw_n', fsdepw_n(:,:,:) ) ! need to compute extrapolation if vvl 
     154                  END IF 
     155      ENDIF 
     156       
     157      IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst    )   
     158 
    142159      IF( kt == nitrst ) THEN 
    143160         CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    … …  
    203220      REAL(wp) ::   zrdt, zrdttra1 
    204221      INTEGER  ::   jk 
    205       LOGICAL  ::   llok 
    206222      !!---------------------------------------------------------------------- 
    207223 
    … …  
    217233         IF( zrdttra1 /= rdttra(1) )   neuler = 0 
    218234      ENDIF 
    219       !  
     235        
     236       
     237      ! Diurnal DSST  
     238      IF( ln_diurnal ) CALL iom_get( numror, jpdom_autoglo, 'Dsst' , x_dsst  )  
     239      IF ( ln_diurnal_only ) THEN  
     240         IF(lwp) WRITE( numout, * ) & 
     241         &   "rst_read:- ln_diurnal_only set, setting rhop=rau0"  
     242         rhop = rau0 
     243         CALL iom_get( numror, jpdom_autoglo, 'tn'     , tsn(:,:,1,jp_tem) )  
     244         RETURN  
     245      ENDIF   
     246       
    220247      IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 
    221248         CALL iom_get( numror, jpdom_autoglo, 'ub'     , ub      )   ! before fields 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6060 r6069  
    1414   !!   'key_mpp_mpi'             MPI massively parallel processing library 
    1515   !!---------------------------------------------------------------------- 
    16    !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
    17    !!   lbc_lnk_e     : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
    18    !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
     16   !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp 
     17   !!   lbc_sum      : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp 
     18   !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp 
     19   !!   lbc_bdy_lnk  : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    1920   !!---------------------------------------------------------------------- 
    2021   USE lib_mpp        ! distributed memory computing library 
    … …  
    2829   END INTERFACE 
    2930   ! 
     31!JMM interface not defined if not key_mpp_mpi : likely do not compile without this CPP key !!!! 
     32   INTERFACE lbc_sum 
     33      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     34   END INTERFACE 
     35 
    3036   INTERFACE lbc_bdy_lnk 
    3137      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    … …  
    4248   PUBLIC   lbc_lnk       ! ocean lateral boundary conditions 
    4349   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
     50   PUBLIC   lbc_sum 
    4451   PUBLIC   lbc_lnk_e     ! 
    4552   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    … …  
    5562   !!   Default option                              shared memory computing 
    5663   !!---------------------------------------------------------------------- 
    57    !!   lbc_lnk      : generic interface for lbc_lnk_3d and lbc_lnk_2d 
    58    !!   lbc_lnk_3d   : set the lateral boundary condition on a 3D variable on ocean mesh 
    59    !!   lbc_lnk_2d   : set the lateral boundary condition on a 2D variable on ocean mesh 
    60    !!   lbc_bdy_lnk  : set the lateral BDY boundary condition 
     64   !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d  
     65   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
     66   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
     67   !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d 
     68   !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh 
     69   !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh 
     70   !!   lbc_bdy_lnk   : set the lateral BDY boundary condition 
    6171   !!---------------------------------------------------------------------- 
    6272   USE oce             ! ocean dynamics and tracers    
    … …  
    7282   END INTERFACE 
    7383   ! 
     84   INTERFACE lbc_sum 
     85      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     86   END INTERFACE 
     87 
    7488   INTERFACE lbc_lnk_e 
    7589      MODULE PROCEDURE lbc_lnk_2d_e 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6060 r6069  
    7272   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    7373   PUBLIC   mpp_lnk_2d_9  
     74   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7475   PUBLIC   mppscatter, mppgather 
    7576   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    13911392   END SUBROUTINE mpp_lnk_2d_e 
    13921393 
     1394   SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
     1395      !!---------------------------------------------------------------------- 
     1396      !!                  ***  routine mpp_lnk_sum_3d  *** 
     1397      !! 
     1398      !! ** Purpose :   Message passing manadgement (sum the overlap region) 
     1399      !! 
     1400      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     1401      !!      between processors following neighboring subdomains. 
     1402      !!            domain parameters 
     1403      !!                    nlci   : first dimension of the local subdomain 
     1404      !!                    nlcj   : second dimension of the local subdomain 
     1405      !!                    nbondi : mark for "east-west local boundary" 
     1406      !!                    nbondj : mark for "north-south local boundary" 
     1407      !!                    noea   : number for local neighboring processors 
     1408      !!                    nowe   : number for local neighboring processors 
     1409      !!                    noso   : number for local neighboring processors 
     1410      !!                    nono   : number for local neighboring processors 
     1411      !! 
     1412      !! ** Action  :   ptab with update value at its periphery 
     1413      !! 
     1414      !!---------------------------------------------------------------------- 
     1415      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     1416      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     1417      !                                                             ! = T , U , V , F , W points 
     1418      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     1419      !                                                             ! =  1. , the sign is kept 
     1420      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     1421      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     1422      !! 
     1423      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
     1424      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     1425      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     1426      REAL(wp) ::   zland 
     1427      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     1428      ! 
     1429      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north 
     1430      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east 
     1431 
     1432      !!---------------------------------------------------------------------- 
     1433       
     1434      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   & 
     1435         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  ) 
     1436 
     1437      ! 
     1438      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     1439      ELSE                         ;   zland = 0.e0      ! zero by default 
     1440      ENDIF 
     1441 
     1442      ! 1. standard boundary treatment 
     1443      ! ------------------------------ 
     1444      ! 2. East and west directions exchange 
     1445      ! ------------------------------------ 
     1446      ! we play with the neigbours AND the row number because of the periodicity 
     1447      ! 
     1448      SELECT CASE ( nbondi )      ! Read lateral conditions 
     1449      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     1450      iihom = nlci-jpreci 
     1451         DO jl = 1, jpreci 
     1452            zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0.0_wp 
     1453            zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp  
     1454         END DO 
     1455      END SELECT 
     1456      ! 
     1457      !                           ! Migrations 
     1458      imigr = jpreci * jpj * jpk 
     1459      ! 
     1460      SELECT CASE ( nbondi ) 
     1461      CASE ( -1 ) 
     1462         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 
     1463         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
     1464         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     1465      CASE ( 0 ) 
     1466         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     1467         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 
     1468         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 
     1469         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
     1470         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     1471         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     1472      CASE ( 1 ) 
     1473         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 
     1474         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 
     1475         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     1476      END SELECT 
     1477      ! 
     1478      !                           ! Write lateral conditions 
     1479      iihom = nlci-nreci 
     1480      ! 
     1481      SELECT CASE ( nbondi ) 
     1482      CASE ( -1 ) 
     1483         DO jl = 1, jpreci 
     1484            ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 
     1485         END DO 
     1486      CASE ( 0 ) 
     1487         DO jl = 1, jpreci 
     1488            ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
     1489            ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 
     1490         END DO 
     1491      CASE ( 1 ) 
     1492         DO jl = 1, jpreci 
     1493            ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 
     1494         END DO 
     1495      END SELECT 
     1496 
     1497 
     1498      ! 3. North and south directions 
     1499      ! ----------------------------- 
     1500      ! always closed : we play only with the neigbours 
     1501      ! 
     1502      IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
     1503         ijhom = nlcj-jprecj 
     1504         DO jl = 1, jprecj 
     1505            zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 
     1506            zt3ns(:,jl,:,1) = ptab(:,jl      ,:) ; ptab(:,jl      ,:) = 0.0_wp 
     1507         END DO 
     1508      ENDIF 
     1509      ! 
     1510      !                           ! Migrations 
     1511      imigr = jprecj * jpi * jpk 
     1512      ! 
     1513      SELECT CASE ( nbondj ) 
     1514      CASE ( -1 ) 
     1515         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 
     1516         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
     1517         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     1518      CASE ( 0 ) 
     1519         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     1520         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 
     1521         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 
     1522         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
     1523         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     1524         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 
     1525      CASE ( 1 ) 
     1526         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 
     1527         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 
     1528         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 
     1529      END SELECT 
     1530      ! 
     1531      !                           ! Write lateral conditions 
     1532      ijhom = nlcj-nrecj 
     1533      ! 
     1534      SELECT CASE ( nbondj ) 
     1535      CASE ( -1 ) 
     1536         DO jl = 1, jprecj 
     1537            ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 
     1538         END DO 
     1539      CASE ( 0 ) 
     1540         DO jl = 1, jprecj 
     1541            ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 
     1542            ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 
     1543         END DO 
     1544      CASE ( 1 ) 
     1545         DO jl = 1, jprecj 
     1546            ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2) 
     1547         END DO 
     1548      END SELECT 
     1549 
     1550 
     1551      ! 4. north fold treatment 
     1552      ! ----------------------- 
     1553      ! 
     1554      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     1555         ! 
     1556         SELECT CASE ( jpni ) 
     1557         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
     1558         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     1559         END SELECT 
     1560         ! 
     1561      ENDIF 
     1562      ! 
     1563      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 
     1564      ! 
     1565   END SUBROUTINE mpp_lnk_sum_3d 
     1566 
     1567   SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     1568      !!---------------------------------------------------------------------- 
     1569      !!                  ***  routine mpp_lnk_sum_2d  *** 
     1570      !! 
     1571      !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region) 
     1572      !! 
     1573      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     1574      !!      between processors following neighboring subdomains. 
     1575      !!            domain parameters 
     1576      !!                    nlci   : first dimension of the local subdomain 
     1577      !!                    nlcj   : second dimension of the local subdomain 
     1578      !!                    nbondi : mark for "east-west local boundary" 
     1579      !!                    nbondj : mark for "north-south local boundary" 
     1580      !!                    noea   : number for local neighboring processors 
     1581      !!                    nowe   : number for local neighboring processors 
     1582      !!                    noso   : number for local neighboring processors 
     1583      !!                    nono   : number for local neighboring processors 
     1584      !! 
     1585      !!---------------------------------------------------------------------- 
     1586      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied 
     1587      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
     1588      !                                                         ! = T , U , V , F , W and I points 
     1589      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
     1590      !                                                         ! =  1. , the sign is kept 
     1591      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     1592      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     1593      !! 
     1594      INTEGER  ::   ji, jj, jl   ! dummy loop indices 
     1595      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers 
     1596      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     1597      REAL(wp) ::   zland 
     1598      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     1599      ! 
     1600      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north 
     1601      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east 
     1602 
     1603      !!---------------------------------------------------------------------- 
     1604 
     1605      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  & 
     1606         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   ) 
     1607 
     1608      ! 
     1609      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
     1610      ELSE                         ;   zland = 0.e0      ! zero by default 
     1611      ENDIF 
     1612 
     1613      ! 1. standard boundary treatment 
     1614      ! ------------------------------ 
     1615      ! 2. East and west directions exchange 
     1616      ! ------------------------------------ 
     1617      ! we play with the neigbours AND the row number because of the periodicity 
     1618      ! 
     1619      SELECT CASE ( nbondi )      ! Read lateral conditions 
     1620      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     1621         iihom = nlci - jpreci 
     1622         DO jl = 1, jpreci 
     1623            zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp 
     1624            zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 
     1625         END DO 
     1626      END SELECT 
     1627      ! 
     1628      !                           ! Migrations 
     1629      imigr = jpreci * jpj 
     1630      ! 
     1631      SELECT CASE ( nbondi ) 
     1632      CASE ( -1 ) 
     1633         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 
     1634         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
     1635         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1636      CASE ( 0 ) 
     1637         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1638         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 
     1639         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 
     1640         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
     1641         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1642         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1643      CASE ( 1 ) 
     1644         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 
     1645         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 
     1646         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1647      END SELECT 
     1648      ! 
     1649      !                           ! Write lateral conditions 
     1650      iihom = nlci-nreci 
     1651      ! 
     1652      SELECT CASE ( nbondi ) 
     1653      CASE ( -1 ) 
     1654         DO jl = 1, jpreci 
     1655            pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 
     1656         END DO 
     1657      CASE ( 0 ) 
     1658         DO jl = 1, jpreci 
     1659            pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
     1660            pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 
     1661         END DO 
     1662      CASE ( 1 ) 
     1663         DO jl = 1, jpreci 
     1664            pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 
     1665         END DO 
     1666      END SELECT 
     1667 
     1668 
     1669      ! 3. North and south directions 
     1670      ! ----------------------------- 
     1671      ! always closed : we play only with the neigbours 
     1672      ! 
     1673      IF( nbondj /= 2 ) THEN      ! Read lateral conditions 
     1674         ijhom = nlcj - jprecj 
     1675         DO jl = 1, jprecj 
     1676            zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 
     1677            zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp 
     1678         END DO 
     1679      ENDIF 
     1680      ! 
     1681      !                           ! Migrations 
     1682      imigr = jprecj * jpi 
     1683      ! 
     1684      SELECT CASE ( nbondj ) 
     1685      CASE ( -1 ) 
     1686         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 
     1687         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
     1688         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1689      CASE ( 0 ) 
     1690         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
     1691         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 
     1692         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 
     1693         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
     1694         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1695         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     1696      CASE ( 1 ) 
     1697         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 
     1698         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 
     1699         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     1700      END SELECT 
     1701      ! 
     1702      !                           ! Write lateral conditions 
     1703      ijhom = nlcj-nrecj 
     1704      ! 
     1705      SELECT CASE ( nbondj ) 
     1706      CASE ( -1 ) 
     1707         DO jl = 1, jprecj 
     1708            pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 
     1709         END DO 
     1710      CASE ( 0 ) 
     1711         DO jl = 1, jprecj 
     1712            pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
     1713            pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 
     1714         END DO 
     1715      CASE ( 1 ) 
     1716         DO jl = 1, jprecj 
     1717            pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 
     1718         END DO 
     1719      END SELECT 
     1720 
     1721 
     1722      ! 4. north fold treatment 
     1723      ! ----------------------- 
     1724      ! 
     1725      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     1726         ! 
     1727         SELECT CASE ( jpni ) 
     1728         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp 
     1729         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs. 
     1730         END SELECT 
     1731         ! 
     1732      ENDIF 
     1733      ! 
     1734      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     1735      ! 
     1736   END SUBROUTINE mpp_lnk_sum_2d 
    13931737 
    13941738   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r5130 r6069  
    136136 
    137137      imask(:,:)=1 
    138       WHERE ( zdta(:,:) - zdtaisf(:,:) <= 0. ) imask = 0 
     138      WHERE ( zdta(:,:) - zdtaisf(:,:) <= rn_isfhmin ) imask = 0 
    139139 
    140140      !  1. Dimension arrays for subdomains 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r6060 r6069  
    111111      !! 
    112112      INTEGER  ::   ji , jj , jk    ! dummy loop indices 
    113       INTEGER  ::   ii0, ii1, iku   ! temporary integer 
    114       INTEGER  ::   ij0, ij1, ikv   ! temporary integer 
     113      INTEGER  ::   ii0, ii1        ! temporary integer 
     114      INTEGER  ::   ij0, ij1        ! temporary integer 
    115115      REAL(wp) ::   zeps, zm1_g, zm1_2g, z1_16, zcofw, z1_slpmax ! local scalars 
    116116      REAL(wp) ::   zci, zfi, zau, zbu, zai, zbi   !   -      - 
    117117      REAL(wp) ::   zcj, zfj, zav, zbv, zaj, zbj   !   -      - 
    118118      REAL(wp) ::   zck, zfk,      zbw             !   -      - 
     119      REAL(wp) ::   zdepu, zdepv                   !   -      - 
     120      REAL(wp), POINTER, DIMENSION(:,:  ) ::  zslpml_hmlpu, zslpml_hmlpv 
    119121      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwz, zww 
    120122      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdzr 
    … …  
    125127      ! 
    126128      CALL wrk_alloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 
     129      CALL wrk_alloc( jpi,jpj, zslpml_hmlpu, zslpml_hmlpv ) 
    127130 
    128131      zeps   =  1.e-20_wp        !==   Local constant initialization   ==! 
    … …  
    148151               zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
    149152               zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
     153            END DO 
     154         END DO 
     155      ENDIF 
     156      IF( ln_zps .AND. ln_isfcav ) THEN           ! partial steps correction at the bottom ocean level 
     157         DO jj = 1, jpjm1 
     158            DO ji = 1, jpim1 
     159               IF ( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj)  
     160               IF ( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj) 
    150161            END DO 
    151162         END DO 
    … …  
    170181      ! ===========================      | vslp = d/dj( prd ) / d/dz( prd ) 
    171182      ! 
     183      IF ( ln_isfcav ) THEN 
     184         DO jj = 2, jpjm1 
     185            DO ji = fs_2, fs_jpim1   ! vector opt. 
     186               zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp)       & 
     187                  &                                  - 0.5_wp * ( risfdep(ji,jj) + risfdep(ji+1,jj  ) ) ) 
     188               zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp)       & 
     189                  &                                  - 0.5_wp * ( risfdep(ji,jj) + risfdep(ji  ,jj+1) ) ) 
     190            END DO 
     191         END DO 
     192      ELSE 
     193         DO jj = 2, jpjm1 
     194            DO ji = fs_2, fs_jpim1   ! vector opt. 
     195               zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp) 
     196               zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp) 
     197            END DO 
     198         END DO 
     199      END IF 
     200 
    172201      DO jk = 2, jpkm1                            !* Slopes at u and v points 
    173202         DO jj = 2, jpjm1 
    … …  
    185214               zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) 
    186215               zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) ) 
    187                zwz(ji,jj,jk) = ( ( 1. - zfi) * zau / ( zbu - zeps )                                                & 
    188                   &                   + zfi  * uslpml(ji,jj)                                                       & 
    189                   &                          * 0.5_wp * ( gdept_n(ji+1,jj,jk)+gdept_n(ji,jj,jk)-e3u_n(ji,jj,1) )   & 
    190                   &                          / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 5._wp ) ) * umask(ji,jj,jk) 
    191                zww(ji,jj,jk) = ( ( 1. - zfj) * zav / ( zbv - zeps )                                                & 
    192                   &                   + zfj  * vslpml(ji,jj)                                                       & 
    193                   &                          * 0.5_wp * ( gdept_n(ji,jj+1,jk)+gdept_n(ji,jj,jk)-e3v_n(ji,jj,1) )   & 
    194                   &                          / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 5. ) ) * vmask(ji,jj,jk) 
     216               ! thickness of water column between surface and level k at u/v point 
     217               zdepu = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji+1,jj  ,jk) )                            & 
     218                                - ( risfdep(ji,jj)    + risfdep(ji+1,jj)    ) - e3u_n(ji,jj,miku(ji,jj)) ) 
     219               zdepv = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji,jj+1,jk) )                              & 
     220                                - ( risfdep(ji,jj)    + risfdep(ji,jj+1)    ) - e3v_n(ji,jj,mikv(ji,jj)) ) 
     221               ! 
     222               zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps )                                     & 
     223                  &                      + zfi  * zdepu * zslpml_hmlpu(ji,jj) ) * umask(ji,jj,jk) 
     224               zww(ji,jj,jk) = ( ( 1._wp - zfj) * zav / ( zbv - zeps )                                     & 
     225                  &                      + zfj  * zdepv * zslpml_hmlpv(ji,jj) ) * vmask(ji,jj,jk) 
    195226!!gm  modif to suppress omlmask.... (as in Griffies case) 
    196227!               !                                         ! jk must be >= ML level for zf=1. otherwise  zf=0. 
    … …  
    264295                  &      + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk  ) , zeps  ) * e2t(ji,jj) 
    265296               zai =    (  zgru (ji-1,jj,jk  ) + zgru (ji,jj,jk-1)           & 
    266                   &      + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk  )   ) / zci * tmask (ji,jj,jk) 
     297                  &      + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk  )   ) / zci * wmask (ji,jj,jk) 
    267298               zaj =    (  zgrv (ji,jj-1,jk  ) + zgrv (ji,jj,jk-1)           & 
    268                   &      + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk  )   ) / zcj * tmask (ji,jj,jk) 
     299                  &      + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk  )   ) / zcj * wmask (ji,jj,jk) 
    269300               !                                        ! bound the slopes: abs(zw.)<= 1/100 and zb..<0. 
    270301               !                                        ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
    … …  
    273304               !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 
    274305               zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0 
    275                zck = gdepw_n(ji,jj,jk) / MAX( hmlp(ji,jj), 10._wp ) 
    276                zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk  ) * tmask(ji,jj,jk) 
    277                zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk  ) * tmask(ji,jj,jk) 
     306               zck = ( gdepw_n(ji,jj,jk) - gdepw_n(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj) - gdepw_n(ji,jj,mikt(ji,jj)), 10._wp ) 
     307               zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk  ) * wmask(ji,jj,jk) 
     308               zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk  ) * wmask(ji,jj,jk) 
    278309 
    279310!!gm  modif to suppress omlmask....  (as in Griffies operator) 
    … …  
    339370      CALL lbc_lnk( wslpi, 'W', -1. )      ;      CALL lbc_lnk( wslpj, 'W', -1. ) 
    340371 
    341  
    342372      IF(ln_ctl) THEN 
    343373         CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp  - u : ', tab3d_2=vslp,  clinfo2=' v : ', kdim=jpk) 
    … …  
    346376      ! 
    347377      CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 
     378      CALL wrk_dealloc( jpi,jpj, zslpml_hmlpu, zslpml_hmlpv ) 
    348379      ! 
    349380      IF( nn_timing == 1 )  CALL timing_stop('ldf_slp') 
    … …  
    485516                  ! 
    486517                  jk = nmln(ji,jj+jp) + 1 
    487                   IF( jk .GT. mbkt(ji,jj+jp) ) THEN  !ML reaches bottom 
     518                  IF( jk > mbkt(ji,jj+jp) ) THEN  !ML reaches bottom 
    488519                     ztj_mlb(ji   ,jj+jp,1-jp,kp) = 0.0_wp 
    489520                  ELSE 
    … …  
    698729            zcj = MAX(   vmask(ji,jj-1,ik  ) + vmask(ji,jj,ik  )           & 
    699730               &       + vmask(ji,jj-1,ikm1) + vmask(ji,jj,ikm1) , zeps  ) * e2t(ji,jj) 
    700             zai =    (   p_gru(ji-1,jj,ik  ) + p_gru(ji,jj,ik)           & 
     731            zai =    (   p_gru(ji-1,jj,ik  ) + p_gru(ji,jj,ik)             & 
    701732               &       + p_gru(ji-1,jj,ikm1) + p_gru(ji,jj,ikm1  )  ) / zci  * tmask(ji,jj,ik) 
    702733            zaj =    (   p_grv(ji,jj-1,ik  ) + p_grv(ji,jj,ik  )           & 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

    r4990 r6069  
    77 
    88   !!---------------------------------------------------------------------- 
    9    !!   'key_diaobs' : Switch on the observation diagnostic computation 
    10    !!---------------------------------------------------------------------- 
    119   !!   dia_obs_init : Reading and prepare observations 
    1210   !!   dia_obs      : Compute model equivalent to observations 
    1311   !!   dia_obs_wri  : Write observational diagnostics 
     12   !!   calc_date    : Compute the date of timestep in YYYYMMDD.HHMMSS format 
    1413   !!   ini_date     : Compute the initial date YYYYMMDD.HHMMSS 
    1514   !!   fin_date     : Compute the final date YYYYMMDD.HHMMSS 
    1615   !!---------------------------------------------------------------------- 
    17    !! * Modules used    
     16   !! * Modules used 
    1817   USE wrk_nemo                 ! Memory Allocation 
    1918   USE par_kind                 ! Precision variables 
    … …  
    2120   USE par_oce 
    2221   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   
     22   USE obs_read_prof            ! Reading and allocation of profile obs 
     23   USE obs_read_surf            ! Reading and allocation of surface obs 
     24   USE obs_sstbias              ! Bias correction routine for SST  
    2725   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 
    3026   USE obs_prep                 ! Preparation of obs. (grid search etc). 
    3127   USE obs_oper                 ! Observation operators 
    … …  
    3430   USE obs_read_altbias         ! Bias treatment for altimeter 
    3531   USE obs_profiles_def         ! Profile data definitions 
    36    USE obs_profiles             ! Profile data storage 
    3732   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 
    4133   USE obs_types                ! Definitions for observation types 
    4234   USE mpp_map                  ! MPP mapping 
    … …  
    5042      &   dia_obs,      &  ! Compute model equivalent to observations 
    5143      &   dia_obs_wri,  &  ! Write model equivalent to observations 
    52       &   dia_obs_dealloc  ! Deallocate dia_obs data 
    53  
    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 
     44      &   dia_obs_dealloc, &  ! Deallocate dia_obs data 
     45      &   calc_date           ! Compute the date of a timestep 
    6146 
    6247   !! * 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  
     48   LOGICAL, PUBLIC :: ln_diaobs   !: Logical switch for the obs operator 
     49   LOGICAL :: ln_sstnight         !: Logical switch for night mean SST obs 
     50    
     51   INTEGER :: nn_1dint       !: Vertical interpolation method 
     52   INTEGER :: nn_2dint       !: Horizontal interpolation method 
    9653   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? 
    107    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 
     54      & nn_profdavtypes      !: Profile data types representing a daily average 
     55   INTEGER :: nproftypes     !: Number of profile obs types 
     56   INTEGER :: nsurftypes     !: Number of surface obs types 
     57   INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     58      & nvarsprof, &         !: Number of profile variables 
     59      & nvarssurf            !: Number of surface variables 
     60   INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     61      & nextrprof, &         !: Number of profile extra variables 
     62      & nextrsurf            !: Number of surface extra variables 
     63   INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sstbias_type !SST bias type     
     64   TYPE(obs_surf), PUBLIC, POINTER, DIMENSION(:) :: & 
     65      & surfdata, &          !: Initial surface data 
     66      & surfdataqc           !: Surface data after quality control 
     67   TYPE(obs_prof), PUBLIC, POINTER, DIMENSION(:) :: & 
     68      & profdata, &          !: Initial profile data 
     69      & profdataqc           !: Profile data after quality control 
     70 
     71   CHARACTER(len=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: & 
     72      & cobstypesprof, &     !: Profile obs types 
     73      & cobstypessurf        !: Surface obs types 
    11374 
    11475   !!---------------------------------------------------------------------- 
    … …  
    11879   !!---------------------------------------------------------------------- 
    11980 
     81   !! * Substitutions  
     82#  include "domzgr_substitute.h90" 
    12083CONTAINS 
    12184 
    … …  
    13598      !!        !  06-10  (A. Weaver) Cleaning and add controls 
    13699      !!        !  07-03  (K. Mogensen) General handling of profiles 
     100      !!        !  14-08  (J.While) Incorporated SST bias correction   
     101      !!        !  15-02  (M. Martin) Simplification of namelist and code 
    137102      !!---------------------------------------------------------------------- 
    138103 
    … …  
    140105 
    141106      !! * 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,                                    & 
     107      INTEGER, PARAMETER :: & 
     108         & jpmaxnfiles = 1000    ! Maximum number of files for each obs type 
     109      INTEGER, DIMENSION(:), ALLOCATABLE :: & 
     110         & ifilesprof, &         ! Number of profile files 
     111         & ifilessurf            ! Number of surface files 
     112      INTEGER :: ios             ! Local integer output status for namelist read 
     113      INTEGER :: jtype           ! Counter for obs types 
     114      INTEGER :: jvar            ! Counter for variables 
     115      INTEGER :: jfile           ! Counter for files 
     116 
     117      CHARACTER(len=128), DIMENSION(jpmaxnfiles) :: & 
     118         & cn_profbfiles, &      ! T/S profile input filenames 
     119         & cn_sstfbfiles, &      ! Sea surface temperature input filenames 
     120         & cn_slafbfiles, &      ! Sea level anomaly input filenames 
     121         & cn_sicfbfiles, &      ! Seaice concentration input filenames 
     122         & cn_velfbfiles, &      ! Velocity profile input filenames 
     123         & cn_sstbias_files      ! SST bias input filenames 
     124      CHARACTER(LEN=128) :: & 
     125         & cn_altbiasfile        ! Altimeter bias input filename 
     126      CHARACTER(len=128), DIMENSION(:,:), ALLOCATABLE :: & 
     127         & clproffiles, &        ! Profile filenames 
     128         & clsurffiles           ! Surface filenames 
     129 
     130      LOGICAL :: ln_t3d          ! Logical switch for temperature profiles 
     131      LOGICAL :: ln_s3d          ! Logical switch for salinity profiles 
     132      LOGICAL :: ln_sla          ! Logical switch for sea level anomalies  
     133      LOGICAL :: ln_sst          ! Logical switch for sea surface temperature 
     134      LOGICAL :: ln_sic          ! Logical switch for sea ice concentration 
     135      LOGICAL :: ln_vel3d        ! Logical switch for velocity (u,v) obs 
     136      LOGICAL :: ln_nea          ! Logical switch to remove obs near land 
     137      LOGICAL :: ln_altbias      ! Logical switch for altimeter bias 
     138      LOGICAL :: ln_sstbias     !: Logical switch for bias corection of SST  
     139      LOGICAL :: ln_ignmis       ! Logical switch for ignoring missing files 
     140      LOGICAL :: ln_s_at_t       ! Logical switch to compute model S at T obs 
     141      LOGICAL :: llvar1          ! Logical for profile variable 1 
     142      LOGICAL :: llvar2          ! Logical for profile variable 1 
     143      LOGICAL :: llnightav       ! Logical for calculating night-time averages 
     144      LOGICAL, DIMENSION(jpmaxnfiles) :: lmask ! Used for finding number of sstbias files 
     145 
     146      REAL(dp) :: rn_dobsini     ! Obs window start date YYYYMMDD.HHMMSS 
     147      REAL(dp) :: rn_dobsend     ! Obs window end date   YYYYMMDD.HHMMSS 
     148      REAL(wp), POINTER, DIMENSION(:,:) :: & 
     149         & zglam1, &             ! Model longitudes for profile variable 1 
     150         & zglam2                ! Model longitudes for profile variable 2 
     151      REAL(wp), POINTER, DIMENSION(:,:) :: & 
     152         & zgphi1, &             ! Model latitudes for profile variable 1 
     153         & zgphi2                ! Model latitudes for profile variable 2 
     154      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     155         & zmask1, &             ! Model land/sea mask associated with variable 1 
     156         & zmask2                ! Model land/sea mask associated with variable 2 
     157 
     158      NAMELIST/namobs/ln_diaobs, ln_t3d, ln_s3d, ln_sla,              & 
     159         &            ln_sst, ln_sic, ln_vel3d,                       & 
     160         &            ln_altbias, ln_nea, ln_grid_global,             & 
    173161         &            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 
     162         &            ln_ignmis, ln_s_at_t, ln_sstnight,              & 
     163         &            cn_profbfiles, cn_slafbfiles,                   & 
     164         &            cn_sstfbfiles, cn_sicfbfiles,                   & 
     165         &            cn_velfbfiles, cn_altbiasfile,                  & 
     166         &            cn_gridsearchfile, rn_gridsearchres,            & 
     167         &            rn_dobsini, rn_dobsend, nn_1dint, nn_2dint,     & 
     168         &            nn_msshc, rn_mdtcorr, rn_mdtcutoff,             & 
     169         &            nn_profdavtypes, ln_sstbias, cn_sstbias_files 
     170 
     171      INTEGER :: jnumsstbias 
     172      CALL wrk_alloc( jpi, jpj, zglam1 ) 
     173      CALL wrk_alloc( jpi, jpj, zglam2 ) 
     174      CALL wrk_alloc( jpi, jpj, zgphi1 ) 
     175      CALL wrk_alloc( jpi, jpj, zgphi2 ) 
     176      CALL wrk_alloc( jpi, jpj, jpk, zmask1 ) 
     177      CALL wrk_alloc( jpi, jpj, jpk, zmask2 ) 
    205178 
    206179      !----------------------------------------------------------------------- 
    207180      ! Read namelist parameters 
    208181      !----------------------------------------------------------------------- 
    209  
    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. 
    234182       
    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 
     183      !Initalise all values in namelist arrays 
     184      ALLOCATE(sstbias_type(jpmaxnfiles)) 
     185      ! Some namelist arrays need initialising 
     186      cn_profbfiles(:) = '' 
     187      cn_slafbfiles(:) = '' 
     188      cn_sstfbfiles(:) = '' 
     189      cn_sicfbfiles(:) = '' 
     190      cn_velfbfiles(:) = '' 
     191      cn_sstbias_files(:) = '' 
     192      nn_profdavtypes(:) = -1 
     193 
     194      CALL ini_date( rn_dobsini ) 
     195      CALL fin_date( rn_dobsend ) 
     196 
     197      ! Read namelist namobs : control observation diagnostics 
     198      REWIND( numnam_ref )   ! Namelist namobs in reference namelist 
    240199      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 
    241200901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 
    242201 
    243       REWIND( numnam_cfg )              ! Namelist namobs in configuration namelist : Diagnostic: control observation 
     202      REWIND( numnam_cfg )   ! Namelist namobs in configuration namelist 
    244203      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 
    245204902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 
    246205      IF(lwm) WRITE ( numond, namobs ) 
    247206 
    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) 
    253       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) 
     207      IF ( .NOT. ln_diaobs ) THEN 
     208         IF(lwp) WRITE(numout,cform_war) 
     209         IF(lwp) WRITE(numout,*)' ln_diaobs is set to false so not calling dia_obs' 
     210         RETURN 
     211      ENDIF 
     212       
     213      !----------------------------------------------------------------------- 
     214      ! Set up list of observation types to be used 
     215      ! and the files associated with each type 
     216      !----------------------------------------------------------------------- 
     217 
     218      nproftypes = COUNT( (/ln_t3d .OR. ln_s3d, ln_vel3d /) ) 
     219      nsurftypes = COUNT( (/ln_sla, ln_sst, ln_sic /) ) 
     220 
     221      IF (ln_sstbias) THEN  
     222         lmask(:) = .FALSE.  
     223         WHERE (cn_sstbias_files(:) /= '') lmask(:) = .TRUE.  
     224         jnumsstbias = COUNT(lmask)  
     225         lmask(:) = .FALSE.  
    282226      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 
     227 
     228      IF ( nproftypes == 0 .AND. nsurftypes == 0 ) THEN 
     229         IF(lwp) WRITE(numout,cform_war) 
     230         IF(lwp) WRITE(numout,*) ' ln_diaobs is set to true, but all obs operator logical flags', & 
     231            &                    ' ln_t3d, ln_s3d, ln_sla, ln_sst, ln_sic, ln_vel3d', & 
     232            &                    ' are set to .FALSE. so turning off calls to dia_obs' 
     233         nwarn = nwarn + 1 
     234         ln_diaobs = .FALSE. 
     235         RETURN 
     236      ENDIF 
     237 
     238      IF ( nproftypes > 0 ) THEN 
     239 
     240         ALLOCATE( cobstypesprof(nproftypes) ) 
     241         ALLOCATE( ifilesprof(nproftypes) ) 
     242         ALLOCATE( clproffiles(nproftypes,jpmaxnfiles) ) 
     243 
     244         jtype = 0 
     245         IF (ln_t3d .OR. ln_s3d) THEN 
     246            jtype = jtype + 1 
     247            clproffiles(jtype,:) = cn_profbfiles(:) 
     248            cobstypesprof(jtype) = 'prof  ' 
     249            ifilesprof(jtype) = 0 
     250            DO jfile = 1, jpmaxnfiles 
     251               IF ( trim(clproffiles(jtype,jfile)) /= '' ) & 
     252                  ifilesprof(jtype) = ifilesprof(jtype) + 1 
     253            END DO 
     254         ENDIF 
     255         IF (ln_vel3d) THEN 
     256            jtype = jtype + 1 
     257            clproffiles(jtype,:) = cn_velfbfiles(:) 
     258            cobstypesprof(jtype) = 'vel   ' 
     259            ifilesprof(jtype) = 0 
     260            DO jfile = 1, jpmaxnfiles 
     261               IF ( trim(clproffiles(jtype,jfile)) /= '' ) & 
     262                  ifilesprof(jtype) = ifilesprof(jtype) + 1 
     263            END DO 
     264         ENDIF 
     265 
     266      ENDIF 
     267 
     268      IF ( nsurftypes > 0 ) THEN 
     269 
     270         ALLOCATE( cobstypessurf(nsurftypes) ) 
     271         ALLOCATE( ifilessurf(nsurftypes) ) 
     272         ALLOCATE( clsurffiles(nsurftypes, jpmaxnfiles) ) 
     273 
     274         jtype = 0 
     275         IF (ln_sla) THEN 
     276            jtype = jtype + 1 
     277            clsurffiles(jtype,:) = cn_slafbfiles(:) 
     278            cobstypessurf(jtype) = 'sla   ' 
     279            ifilessurf(jtype) = 0 
     280            DO jfile = 1, jpmaxnfiles 
     281               IF ( trim(clsurffiles(jtype,jfile)) /= '' ) & 
     282                  ifilessurf(jtype) = ifilessurf(jtype) + 1 
     283            END DO 
     284         ENDIF 
     285         IF (ln_sst) THEN 
     286            jtype = jtype + 1 
     287            clsurffiles(jtype,:) = cn_sstfbfiles(:) 
     288            cobstypessurf(jtype) = 'sst   ' 
     289            ifilessurf(jtype) = 0 
     290            DO jfile = 1, jpmaxnfiles 
     291               IF ( trim(clsurffiles(jtype,jfile)) /= '' ) & 
     292                  ifilessurf(jtype) = ifilessurf(jtype) + 1 
     293            END DO 
     294         ENDIF 
     295#if defined key_lim2 || defined key_lim3 
     296         IF (ln_sic) THEN 
     297            jtype = jtype + 1 
     298            clsurffiles(jtype,:) = cn_sicfbfiles(:) 
     299            cobstypessurf(jtype) = 'sic   ' 
     300            ifilessurf(jtype) = 0 
     301            DO jfile = 1, jpmaxnfiles 
     302               IF ( trim(clsurffiles(jtype,jfile)) /= '' ) & 
     303                  ifilessurf(jtype) = ifilessurf(jtype) + 1 
     304            END DO 
     305         ENDIF 
     306#endif 
     307 
     308      ENDIF 
     309 
     310      !Write namelist settings to stdout 
    322311      IF(lwp) THEN 
    323312         WRITE(numout,*) 
    … …  
    325314         WRITE(numout,*) '~~~~~~~~~~~~' 
    326315         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 
     316         WRITE(numout,*) '             Logical switch for T profile observations                ln_t3d = ', ln_t3d 
     317         WRITE(numout,*) '             Logical switch for S profile observations                ln_s3d = ', ln_s3d 
     318         WRITE(numout,*) '             Logical switch for SLA observations                      ln_sla = ', ln_sla 
     319         WRITE(numout,*) '             Logical switch for SST observations                      ln_sst = ', ln_sst 
     320         WRITE(numout,*) '             Logical switch for Sea Ice observations                  ln_sic = ', ln_sic 
     321         WRITE(numout,*) '             Logical switch for velocity observations               ln_vel3d = ', ln_vel3d 
     322         WRITE(numout,*) '             Global distribution of observations              ln_grid_global = ',ln_grid_global 
     323         WRITE(numout,*) '             Logical switch for SST bias correction         ln_sstbias = ', ln_sstbias  
     324         WRITE(numout,*) '             Logical switch for obs grid search lookup ln_grid_search_lookup = ',ln_grid_search_lookup 
    352325         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)) 
     326            WRITE(numout,*) '             Grid search lookup file header                cn_gridsearchfile = ', cn_gridsearchfile 
     327         WRITE(numout,*) '             Initial date in window YYYYMMDD.HHMMSS               rn_dobsini = ', rn_dobsini 
     328         WRITE(numout,*) '             Final date in window YYYYMMDD.HHMMSS                 rn_dobsend = ', rn_dobsend 
     329         WRITE(numout,*) '             Type of vertical interpolation method                  nn_1dint = ', nn_1dint 
     330         WRITE(numout,*) '             Type of horizontal interpolation method                nn_2dint = ', nn_2dint 
     331         WRITE(numout,*) '             Rejection of observations near land switch               ln_nea = ', ln_nea 
     332         WRITE(numout,*) '             MSSH correction scheme                                 nn_msshc = ', nn_msshc 
     333         WRITE(numout,*) '             MDT  correction                                      rn_mdtcorr = ', rn_mdtcorr 
     334         WRITE(numout,*) '             MDT cutoff for computed correction                 rn_mdtcutoff = ', rn_mdtcutoff 
     335         WRITE(numout,*) '             Logical switch for alt bias                          ln_altbias = ', ln_altbias 
     336         WRITE(numout,*) '             Logical switch for ignoring missing files             ln_ignmis = ', ln_ignmis 
     337         WRITE(numout,*) '             Daily average types                             nn_profdavtypes = ', nn_profdavtypes 
     338         WRITE(numout,*) '             Logical switch for night-time SST obs               ln_sstnight = ', ln_sstnight 
     339         WRITE(numout,*) '          Number of profile obs types: ',nproftypes 
     340 
     341         IF ( nproftypes > 0 ) THEN 
     342            DO jtype = 1, nproftypes 
     343               DO jfile = 1, ifilesprof(jtype) 
     344                  WRITE(numout,'(1X,2A)') '             '//cobstypesprof(jtype)//' input observation file names  = ', & 
     345                     TRIM(clproffiles(jtype,jfile)) 
     346               END DO 
    358347            END DO 
    359348         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)) 
     349 
     350         WRITE(numout,*)'          Number of surface obs types: ',nsurftypes 
     351         IF ( nsurftypes > 0 ) THEN 
     352            DO jtype = 1, nsurftypes 
     353               DO jfile = 1, ifilessurf(jtype) 
     354                  WRITE(numout,'(1X,2A)') '             '//cobstypessurf(jtype)//' input observation file names  = ', & 
     355                     TRIM(clsurffiles(jtype,jfile)) 
     356               END DO 
    364357            END DO 
    365358         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)) 
    371                ELSE 
    372                   WRITE(numout,'(1X,2A)') '             Feedback input observation file name       profbfiles = ', & 
    373                      TRIM(profbfiles(ji)) 
    374                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)) 
    441                ELSE 
    442                   WRITE(numout,'(1X,2A)') '             Vel. feedback input observation file name  velfbfiles = ', & 
    443                      TRIM(velfbfiles(ji)) 
    444                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 
    458  
    459       ENDIF 
    460        
     359         WRITE(numout,*) '~~~~~~~~~~~~' 
     360 
     361      ENDIF 
     362 
     363      !----------------------------------------------------------------------- 
     364      ! Obs operator parameter checking and initialisations 
     365      !----------------------------------------------------------------------- 
     366 
    461367      IF ( ln_vel3d .AND. ( .NOT. ln_grid_global ) ) THEN 
    462368         CALL ctl_stop( 'Velocity data only works with ln_grid_global=.true.' ) 
    … …  
    464370      ENDIF 
    465371 
    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 
     372      IF ( ln_grid_global ) THEN 
     373         CALL ctl_warn( 'ln_grid_global=T may cause memory issues when used with a large number of processors' ) 
     374      ENDIF 
     375 
     376      IF ( ( nn_1dint < 0 ) .OR. ( nn_1dint > 1 ) ) THEN 
    485377         CALL ctl_stop(' Choice of vertical (1D) interpolation method', & 
    486378            &                    ' is not available') 
    487379      ENDIF 
    488       IF ( ( n2dint < 0 ).OR.( n2dint > 4 ) ) THEN 
     380 
     381      IF ( ( nn_2dint < 0 ) .OR. ( nn_2dint > 4 ) ) THEN 
    489382         CALL ctl_stop(' Choice of horizontal (2D) interpolation method', & 
    490383            &                    ' is not available') 
    491384      ENDIF 
    492385 
     386      CALL obs_typ_init 
     387      IF(ln_grid_global) THEN 
     388         CALL mppmap_init 
     389      ENDIF 
     390 
     391      CALL obs_grid_setup( ) 
     392 
    493393      !----------------------------------------------------------------------- 
    494394      ! Depending on switches read the various observation types 
    495395      !----------------------------------------------------------------------- 
    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 
    524              
    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  
     396 
     397      IF ( nproftypes > 0 ) THEN 
     398 
     399         ALLOCATE(profdata(nproftypes)) 
     400         ALLOCATE(profdataqc(nproftypes)) 
     401         ALLOCATE(nvarsprof(nproftypes)) 
     402         ALLOCATE(nextrprof(nproftypes)) 
     403 
     404         DO jtype = 1, nproftypes 
     405 
     406            nvarsprof(jtype) = 2 
     407            IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN 
     408               nextrprof(jtype) = 1 
     409               llvar1 = ln_t3d 
     410               llvar2 = ln_s3d 
     411               zglam1 = glamt 
     412               zgphi1 = gphit 
     413               zmask1 = tmask 
     414               zglam2 = glamt 
     415               zgphi2 = gphit 
     416               zmask2 = tmask 
     417            ENDIF 
     418            IF ( TRIM(cobstypesprof(jtype)) == 'vel' )  THEN 
     419               nextrprof(jtype) = 2 
     420               llvar1 = ln_vel3d 
     421               llvar2 = ln_vel3d 
     422               zglam1 = glamu 
     423               zgphi1 = gphiu 
     424               zmask1 = umask 
     425               zglam2 = glamv 
     426               zgphi2 = gphiv 
     427               zmask2 = vmask 
     428            ENDIF 
     429 
     430            !Read in profile or profile obs types 
     431            CALL obs_rea_prof( profdata(jtype), ifilesprof(jtype),       & 
     432               &               clproffiles(jtype,1:ifilesprof(jtype)), & 
     433               &               nvarsprof(jtype), nextrprof(jtype), nitend-nit000+2, & 
     434               &               rn_dobsini, rn_dobsend, llvar1, llvar2, & 
     435               &               ln_ignmis, ln_s_at_t, .FALSE., & 
     436               &               kdailyavtypes = nn_profdavtypes ) 
     437 
     438            DO jvar = 1, nvarsprof(jtype) 
     439               CALL obs_prof_staend( profdata(jtype), jvar ) 
    539440            END DO 
    540441 
    541             CALL obs_pre_pro( profdata(jprofset), prodatqc(jprofset),   & 
    542                &              ln_t3d, ln_s3d, ln_nea, & 
    543                &              kdailyavtypes=endailyavtypes ) 
    544              
    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 ) 
    570              
    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                    
    596                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 ) 
    605                ENDIF 
    606                 
    607             END DO 
    608  
    609          ENDIF 
    610  
    611       ENDIF 
    612  
    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 
     442            CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), & 
     443               &               llvar1, llvar2, & 
     444               &               jpi, jpj, jpk, & 
     445               &               zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2,  & 
     446               &               ln_nea, kdailyavtypes = nn_profdavtypes ) 
     447 
     448         END DO 
     449 
     450         DEALLOCATE( ifilesprof, clproffiles ) 
     451 
     452      ENDIF 
     453 
     454      IF ( nsurftypes > 0 ) THEN 
     455 
     456         ALLOCATE(surfdata(nsurftypes)) 
     457         ALLOCATE(surfdataqc(nsurftypes)) 
     458         ALLOCATE(nvarssurf(nsurftypes)) 
     459         ALLOCATE(nextrsurf(nsurftypes)) 
     460 
     461         DO jtype = 1, nsurftypes 
     462 
     463            nvarssurf(jtype) = 1 
     464            nextrsurf(jtype) = 0 
     465            llnightav = .FALSE. 
     466            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) nextrsurf(jtype) = 2 
     467            IF ( TRIM(cobstypessurf(jtype)) == 'sst' ) llnightav = ln_sstnight 
     468 
     469            !Read in surface obs types 
     470            CALL obs_rea_surf( surfdata(jtype), ifilessurf(jtype), & 
     471               &               clsurffiles(jtype,1:ifilessurf(jtype)), & 
     472               &               nvarssurf(jtype), nextrsurf(jtype), nitend-nit000+2, & 
     473               &               rn_dobsini, rn_dobsend, ln_ignmis, .FALSE., llnightav ) 
    620474          
    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 
    629475          
    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       
     476            CALL obs_pre_surf( surfdata(jtype), surfdataqc(jtype), ln_nea ) 
     477 
     478            IF ( TRIM(cobstypessurf(jtype)) == 'sla' ) THEN 
     479               CALL obs_rea_mdt( surfdataqc(jtype), nn_2dint ) 
     480               IF ( ln_altbias ) CALL obs_rea_altbias ( surfdataqc(jtype), nn_2dint, cn_altbiasfile ) 
     481            ENDIF 
     482            IF ( TRIM(cobstypessurf(jtype)) == 'sst' .AND. ln_sstbias ) THEN 
     483               !Read in bias field and correct SST. 
     484               IF ( jnumsstbias == 0 ) CALL ctl_stop("ln_sstbias set,"// & 
     485                                                     "  but no bias"// & 
     486                                                     " files to read in")    
     487                  CALL obs_app_sstbias( surfdataqc(jtype), nn_2dint, & 
     488                                        jnumsstbias, cn_sstbias_files(1:jnumsstbias) ) 
     489            ENDIF 
     490         END DO 
     491 
     492         DEALLOCATE( ifilessurf, clsurffiles ) 
     493 
     494      ENDIF 
     495 
     496      CALL wrk_dealloc( jpi, jpj, zglam1 ) 
     497      CALL wrk_dealloc( jpi, jpj, zglam2 ) 
     498      CALL wrk_dealloc( jpi, jpj, zgphi1 ) 
     499      CALL wrk_dealloc( jpi, jpj, zgphi2 ) 
     500      CALL wrk_dealloc( jpi, jpj, jpk, zmask1 ) 
     501      CALL wrk_dealloc( jpi, jpj, jpk, zmask2 ) 
     502 
    967503   END SUBROUTINE dia_obs_init 
    968504 
    … …  
    974510      !! 
    975511      !! ** 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 
    983       !! 
    984       !! ** Action  :  
     512      !!              compute the model equivalent of the following data: 
     513      !!               - Profile data, currently T/S or U/V 
     514      !!               - Surface data, currently SST, SLA or sea-ice concentration. 
     515      !! 
     516      !! ** Action  : 
    985517      !! 
    986518      !! History : 
    … …  
    991523      !!        !  07-04  (G. Smith) Generalized surface operators 
    992524      !!        !  08-10  (M. Valdivieso) obs operator for velocity profiles 
     525      !!        !  14-08  (J. While) observation operator for profiles in  
     526      !!                             generalised vertical coordinates 
     527      !!        !  15-08  (M. Martin) Combined surface/profile routines. 
    993528      !!---------------------------------------------------------------------- 
    994529      !! * Modules used 
    995530      USE dom_oce, ONLY : &             ! Ocean space and time domain variables 
    996          & rdt,           &                        
    997          & gdept_1d,       &              
    998          & tmask, umask, vmask                             
     531#if defined key_vvl  
     532         & gdept_n        
     533#else  
     534         & gdept_1d       
     535#endif                                         
    999536      USE phycst, ONLY : &              ! Physical constants 
    1000537         & rday                          
    1001538      USE oce, ONLY : &                 ! Ocean dynamics and tracers variables 
    1002539         & tsn,  &              
    1003          & un, vn,  & 
    1004          & sshn 
     540         & un, vn, & 
     541         & sshn   
     542      USE phycst, ONLY : &         ! Physical constants 
     543         & rday 
    1005544#if defined  key_lim3 
    1006       USE ice, ONLY : &                     ! LIM Ice model variables 
     545      USE ice, ONLY : &            ! LIM3 Ice model variables 
    1007546         & frld 
    1008547#endif 
    1009548#if defined key_lim2 
    1010       USE ice_2, ONLY : &                     ! LIM Ice model variables 
     549      USE ice_2, ONLY : &          ! LIM2 Ice model variables 
    1011550         & frld 
    1012551#endif 
    … …  
    1014553 
    1015554      !! * Arguments 
    1016       INTEGER, INTENT(IN) :: kstp                         ! Current timestep 
     555      INTEGER, INTENT(IN) :: kstp  ! Current timestep 
    1017556      !! * 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     
     557      INTEGER :: idaystp           ! Number of timesteps per day 
     558      INTEGER :: jtype             ! Data loop variable 
     559      INTEGER :: jvar              ! Variable number 
     560      INTEGER :: ji, jj            ! Loop counters 
     561      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     562         & zprofvar1, &            ! Model values for 1st variable in a prof ob 
     563         & zprofvar2               ! Model values for 2nd variable in a prof ob 
     564      REAL(wp), POINTER, DIMENSION(:,:,:) :: & 
     565         & zprofmask1, &           ! Mask associated with zprofvar1 
     566         & zprofmask2              ! Mask associated with zprofvar2 
     567      REAL(wp), POINTER, DIMENSION(:,:) :: & 
     568         & zsurfvar                ! Model values equivalent to surface ob. 
     569      REAL(wp), POINTER, DIMENSION(:,:) :: & 
     570         & zglam1,    &            ! Model longitudes for prof variable 1 
     571         & zglam2,    &            ! Model longitudes for prof variable 2 
     572         & zgphi1,    &            ! Model latitudes for prof variable 1 
     573         & zgphi2                  ! Model latitudes for prof variable 2 
    1025574#if ! defined key_lim2 && ! defined key_lim3 
    1026       REAL(wp), POINTER, DIMENSION(:,:) :: frld    
     575      REAL(wp), POINTER, DIMENSION(:,:) :: frld 
    1027576#endif 
    1028       CHARACTER(LEN=20) :: datestr=" ",timestr=" " 
    1029   
     577      LOGICAL :: llnightav        ! Logical for calculating night-time average 
     578 
     579      !Allocate local work arrays 
     580      CALL wrk_alloc( jpi, jpj, jpk, zprofvar1 ) 
     581      CALL wrk_alloc( jpi, jpj, jpk, zprofvar2 ) 
     582      CALL wrk_alloc( jpi, jpj, jpk, zprofmask1 ) 
     583      CALL wrk_alloc( jpi, jpj, jpk, zprofmask2 ) 
     584      CALL wrk_alloc( jpi, jpj, zsurfvar ) 
     585      CALL wrk_alloc( jpi, jpj, zglam1 ) 
     586      CALL wrk_alloc( jpi, jpj, zglam2 ) 
     587      CALL wrk_alloc( jpi, jpj, zgphi1 ) 
     588      CALL wrk_alloc( jpi, jpj, zgphi2 ) 
    1030589#if ! defined key_lim2 && ! defined key_lim3 
    1031590      CALL wrk_alloc(jpi,jpj,frld)  
    … …  
    1047606#endif 
    1048607      !----------------------------------------------------------------------- 
    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 ) 
     608      ! Call the profile and surface observation operators 
     609      !----------------------------------------------------------------------- 
     610 
     611      IF ( nproftypes > 0 ) THEN 
     612 
     613         DO jtype = 1, nproftypes 
     614 
     615            SELECT CASE ( TRIM(cobstypesprof(jtype)) ) 
     616            CASE('prof') 
     617               zprofvar1(:,:,:) = tsn(:,:,:,jp_tem) 
     618               zprofvar2(:,:,:) = tsn(:,:,:,jp_sal) 
     619               zprofmask1(:,:,:) = tmask(:,:,:) 
     620               zprofmask2(:,:,:) = tmask(:,:,:) 
     621               zglam1(:,:) = glamt(:,:) 
     622               zglam2(:,:) = glamt(:,:) 
     623               zgphi1(:,:) = gphit(:,:) 
     624               zgphi2(:,:) = gphit(:,:) 
     625            CASE('vel') 
     626               zprofvar1(:,:,:) = un(:,:,:) 
     627               zprofvar2(:,:,:) = vn(:,:,:) 
     628               zprofmask1(:,:,:) = umask(:,:,:) 
     629               zprofmask2(:,:,:) = vmask(:,:,:) 
     630               zglam1(:,:) = glamu(:,:) 
     631               zglam2(:,:) = glamv(:,:) 
     632               zgphi1(:,:) = gphiu(:,:) 
     633               zgphi2(:,:) = gphiv(:,:) 
     634            END SELECT 
     635 
     636            IF( ln_zco .OR. ln_zps ) THEN  
     637               CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk,  & 
     638                  &               nit000, idaystp,                         & 
     639                  &               zprofvar1, zprofvar2,                    & 
     640                  &               gdept_1d, zprofmask1, zprofmask2,        & 
     641                  &               zglam1, zglam2, zgphi1, zgphi2,          & 
     642                  &               nn_1dint, nn_2dint,                      & 
     643                  &               kdailyavtypes = nn_profdavtypes ) 
     644            ELSE IF(TRIM(cobstypesprof(jtype)) == 'prof') THEN 
     645               !TG - THIS NEEDS MODIFICATION TO MATCH SIMPLIFICATION 
     646               CALL obs_pro_sco_opt( profdataqc(jtype),                    &  
     647                  &              kstp, jpi, jpj, jpk, nit000, idaystp,   &  
     648                  &              zprofvar1, zprofvar2,                   &  
     649                  &              fsdept(:,:,:), fsdepw(:,:,:),           & 
     650                  &              tmask, nn_1dint, nn_2dint,              &  
     651                  &              kdailyavtypes = nn_profdavtypes )  
    1061652            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              ) 
     653               CALL ctl_stop('DIA_OBS: Generalised vertical interpolation not'// & 
     654                         'yet working for velocity data (turn off velocity observations') 
    1066655            ENDIF 
     656 
    1067657         END DO 
    1068       ENDIF 
    1069  
    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) ) 
     658 
     659      ENDIF 
     660 
     661      IF ( nsurftypes > 0 ) THEN 
     662 
     663         DO jtype = 1, nsurftypes 
     664 
     665            SELECT CASE ( TRIM(cobstypessurf(jtype)) ) 
     666            CASE('sst') 
     667               zsurfvar(:,:) = tsn(:,:,1,jp_tem) 
     668               llnightav = ln_sstnight 
     669            CASE('sla') 
     670               zsurfvar(:,:) = sshn(:,:) 
     671               llnightav = .FALSE. 
     672#if defined key_lim2 || defined key_lim3 
     673            CASE('sic') 
     674               IF ( kstp == 0 ) THEN 
     675                  IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN 
     676                     CALL ctl_warn( 'Sea-ice not initialised on zeroth '// & 
     677                        &           'time-step but some obs are valid then.' ) 
     678                     WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), & 
     679                        &           ' sea-ice obs will be missed' 
     680                  ENDIF 
     681                  surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + & 
     682                     &                        surfdataqc(jtype)%nsstp(1) 
     683                  CYCLE 
     684               ELSE 
     685                  zsurfvar(:,:) = 1._wp - frld(:,:) 
     686               ENDIF 
     687 
     688               llnightav = .FALSE. 
     689#endif 
     690            END SELECT 
     691 
     692            CALL obs_surf_opt( surfdataqc(jtype), kstp, jpi, jpj,       & 
     693               &               nit000, idaystp, zsurfvar, tmask(:,:,1), & 
     694               &               nn_2dint, llnightav ) 
     695 
    1086696         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       
     697 
     698      ENDIF 
     699 
     700      CALL wrk_dealloc( jpi, jpj, jpk, zprofvar1 ) 
     701      CALL wrk_dealloc( jpi, jpj, jpk, zprofvar2 ) 
     702      CALL wrk_dealloc( jpi, jpj, jpk, zprofmask1 ) 
     703      CALL wrk_dealloc( jpi, jpj, jpk, zprofmask2 ) 
     704      CALL wrk_dealloc( jpi, jpj, zsurfvar ) 
     705      CALL wrk_dealloc( jpi, jpj, zglam1 ) 
     706      CALL wrk_dealloc( jpi, jpj, zglam2 ) 
     707      CALL wrk_dealloc( jpi, jpj, zgphi1 ) 
     708      CALL wrk_dealloc( jpi, jpj, zgphi2 ) 
     709#if ! defined key_lim2 && ! defined key_lim3 
     710      CALL wrk_dealloc(jpi,jpj,frld) 
    1102711#endif 
    1103712 
    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  
    1118713   END SUBROUTINE dia_obs 
    1119    
    1120    SUBROUTINE dia_obs_wri  
     714 
     715   SUBROUTINE dia_obs_wri 
    1121716      !!---------------------------------------------------------------------- 
    1122717      !!                    ***  ROUTINE dia_obs_wri  *** 
    … …  
    1126721      !! ** Method  : Call observation diagnostic output routines 
    1127722      !! 
    1128       !! ** Action  :  
     723      !! ** Action  : 
    1129724      !! 
    1130725      !! History : 
    … …  
    1134729      !!        !  07-03  (K. Mogensen) General handling of profiles 
    1135730      !!        !  08-09  (M. Valdivieso) Velocity component (U,V) profiles 
    1136       !!---------------------------------------------------------------------- 
     731      !!        !  15-08  (M. Martin) Combined writing for prof and surf types 
     732      !!---------------------------------------------------------------------- 
     733      !! * Modules used 
     734      USE obs_rot_vel          ! Rotation of velocities 
     735 
    1137736      IMPLICIT NONE 
    1138737 
    1139738      !! * 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 
     739      INTEGER :: jtype                    ! Data set loop variable 
     740      INTEGER :: jo, jvar, jk 
     741      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
     742         & zu, & 
     743         & zv 
     744 
    1150745      !----------------------------------------------------------------------- 
    1151746      ! Depending on switches call various observation output routines 
    1152747      !----------------------------------------------------------------------- 
    1153748 
    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 ) 
     749      IF ( nproftypes > 0 ) THEN 
     750 
     751         DO jtype = 1, nproftypes 
     752 
     753            IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN 
     754 
     755               ! For velocity data, rotate the model velocities to N/S, E/W 
     756               ! using the compressed data structure. 
     757               ALLOCATE( & 
     758                  & zu(profdataqc(jtype)%nvprot(1)), & 
     759                  & zv(profdataqc(jtype)%nvprot(2))  & 
     760                  & ) 
     761 
     762               CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv ) 
     763 
     764               DO jo = 1, profdataqc(jtype)%nprof 
     765                  DO jvar = 1, 2 
     766                     DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar) 
     767 
     768                        IF ( jvar == 1 ) THEN 
     769                           profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk) 
     770                        ELSE 
     771                           profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk) 
     772                        ENDIF 
     773 
     774                     END DO 
     775                  END DO 
     776               END DO 
     777 
     778               DEALLOCATE( zu ) 
     779               DEALLOCATE( zv ) 
     780 
     781            END IF 
     782 
     783            CALL obs_prof_decompress( profdataqc(jtype), & 
     784               &                      profdata(jtype), .TRUE., numout ) 
     785 
     786            CALL obs_wri_prof( profdata(jtype) ) 
    1163787 
    1164788         END DO 
    1165789 
    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  
    1206       ENDIF 
    1207  
    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 ) 
     790      ENDIF 
     791 
     792      IF ( nsurftypes > 0 ) THEN 
     793 
     794         DO jtype = 1, nsurftypes 
     795 
     796            CALL obs_surf_decompress( surfdataqc(jtype), & 
     797               &                      surfdata(jtype), .TRUE., numout ) 
     798 
     799            CALL obs_wri_surf( surfdata(jtype) ) 
    1216800 
    1217801         END DO 
    1218802 
    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           
    1390803      ENDIF 
    1391804 
    … …  
    1405818      !! 
    1406819      !!---------------------------------------------------------------------- 
    1407       !! obs_grid deallocation 
     820      ! obs_grid deallocation 
    1408821      CALL obs_grid_deallocate 
    1409822 
    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 
     823      ! diaobs deallocation 
     824      IF ( nproftypes > 0 ) & 
     825         &   DEALLOCATE( cobstypesprof, profdata, profdataqc, nvarsprof, nextrprof ) 
     826 
     827      IF ( nsurftypes > 0 ) & 
     828         &   DEALLOCATE( cobstypessurf, surfdata, surfdataqc, nvarssurf, nextrsurf ) 
     829 
    1433830   END SUBROUTINE dia_obs_dealloc 
    1434831 
    1435    SUBROUTINE ini_date( ddobsini ) 
    1436       !!---------------------------------------------------------------------- 
    1437       !!                    ***  ROUTINE ini_date  *** 
     832   SUBROUTINE calc_date( kstp, ddobs ) 
     833      !!---------------------------------------------------------------------- 
     834      !!                    ***  ROUTINE calc_date  *** 
    1438835      !!           
    1439       !! ** Purpose : Get initial data in double precision YYYYMMDD.HHMMSS format 
    1440       !! 
    1441       !! ** Method  : Get initial data in double precision YYYYMMDD.HHMMSS format 
    1442       !! 
    1443       !! ** Action  : Get initial data in double precision YYYYMMDD.HHMMSS format 
     836      !! ** Purpose : Get date in double precision YYYYMMDD.HHMMSS format 
     837      !! 
     838      !! ** Method  : Get date in double precision YYYYMMDD.HHMMSS format 
     839      !! 
     840      !! ** Action  : Get date in double precision YYYYMMDD.HHMMSS format 
     841      !! 
     842      !! ** Action  : Get initial date in double precision YYYYMMDD.HHMMSS format 
    1444843      !! 
    1445844      !! History : 
    … …  
    1449848      !!        !  06-10  (G. Smith) Calculates initial date the same as method for final date 
    1450849      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2 
     850      !!        !  2014-09  (D. Lea) New generic routine now deals with arbitrary initial time of day 
    1451851      !!---------------------------------------------------------------------- 
    1452852      USE phycst, ONLY : &            ! Physical constants 
    1453853         & rday 
    1454 !      USE daymod, ONLY : &            ! Time variables 
    1455 !         & nmonth_len            
    1456854      USE dom_oce, ONLY : &           ! Ocean space and time domain variables 
    1457855         & rdt 
    … …  
    1460858 
    1461859      !! * Arguments 
    1462       REAL(KIND=dp), INTENT(OUT) :: ddobsini                         ! Initial date in YYYYMMDD.HHMMSS 
     860      REAL(KIND=dp), INTENT(OUT) :: ddobs                        ! Date in YYYYMMDD.HHMMSS 
     861      INTEGER :: kstp 
    1463862 
    1464863      !! * Local declarations 
    … …  
    1468867      INTEGER :: ihou 
    1469868      INTEGER :: imin 
    1470       INTEGER :: imday         ! Number of days in month. 
    1471       REAL(KIND=wp) :: zdayfrc ! Fraction of day 
     869      INTEGER :: imday       ! Number of days in month. 
     870      INTEGER, DIMENSION(12) :: & 
     871         &       imonth_len  ! Length in days of the months of the current year 
     872      REAL(wp) :: zdayfrc    ! Fraction of day 
    1472873 
    1473874      INTEGER, DIMENSION(12) ::   imonth_len    !: length in days of the months of the current year 
    … …  
    1475876      !!---------------------------------------------------------------------- 
    1476877      !! Initial date initialization (year, month, day, hour, minute) 
    1477       !! (This assumes that the initial date is for 00z)) 
    1478878      !!---------------------------------------------------------------------- 
    1479879      iyea =   ndate0 / 10000 
    1480880      imon = ( ndate0 - iyea * 10000 ) / 100 
    1481881      iday =   ndate0 - iyea * 10000 - imon * 100 
    1482       ihou = 0 
    1483       imin = 0 
     882      ihou =   nn_time0 / 100 
     883      imin = ( nn_time0 - ihou * 100 )  
    1484884 
    1485885      !!---------------------------------------------------------------------- 
    1486886      !! Compute number of days + number of hours + min since initial time 
    1487887      !!---------------------------------------------------------------------- 
    1488       iday = iday + ( nit000 -1 ) * rdt / rday 
    1489       zdayfrc = ( nit000 -1 ) * rdt / rday 
     888      zdayfrc = kstp * rdt / rday 
    1490889      zdayfrc = zdayfrc - aint(zdayfrc) 
    1491       ihou = int( zdayfrc * 24 ) 
    1492       imin = int( (zdayfrc * 24 - ihou) * 60 ) 
    1493  
    1494       !!----------------------------------------------------------------------- 
    1495       !! Convert number of days (iday) into a real date 
    1496       !!---------------------------------------------------------------------- 
     890      imin = imin + int( zdayfrc * 24 * 60 )  
     891      DO WHILE (imin >= 60)  
     892        imin=imin-60 
     893        ihou=ihou+1 
     894      END DO 
     895      DO WHILE (ihou >= 24) 
     896        ihou=ihou-24 
     897        iday=iday+1 
     898      END DO  
     899      iday = iday + kstp * rdt / rday  
     900 
     901      !----------------------------------------------------------------------- 
     902      ! Convert number of days (iday) into a real date 
     903      !---------------------------------------------------------------------- 
    1497904 
    1498905      CALL calc_month_len( iyea, imonth_len ) 
    1499        
     906 
    1500907      DO WHILE ( iday > imonth_len(imon) ) 
    1501908         iday = iday - imonth_len(imon) 
    … …  
    1508915      END DO 
    1509916 
    1510       !!---------------------------------------------------------------------- 
    1511       !! Convert it into YYYYMMDD.HHMMSS format. 
    1512       !!---------------------------------------------------------------------- 
    1513       ddobsini = iyea * 10000_dp + imon * 100_dp + & 
    1514          &       iday + ihou * 0.01_dp + imin * 0.0001_dp 
    1515  
    1516  
    1517    END SUBROUTINE ini_date 
    1518  
    1519    SUBROUTINE fin_date( ddobsfin ) 
    1520       !!---------------------------------------------------------------------- 
    1521       !!                    ***  ROUTINE fin_date  *** 
     917      !---------------------------------------------------------------------- 
     918      ! Convert it into YYYYMMDD.HHMMSS format. 
     919      !---------------------------------------------------------------------- 
     920      ddobs = iyea * 10000_dp + imon * 100_dp + & 
     921         &    iday + ihou * 0.01_dp + imin * 0.0001_dp 
     922 
     923   END SUBROUTINE calc_date 
     924 
     925   SUBROUTINE ini_date( ddobsini ) 
     926      !!---------------------------------------------------------------------- 
     927      !!                    ***  ROUTINE ini_date  *** 
    1522928      !!           
    1523       !! ** Purpose : Get final data in double precision YYYYMMDD.HHMMSS format 
    1524       !! 
    1525       !! ** Method  : Get final data in double precision YYYYMMDD.HHMMSS format 
    1526       !! 
    1527       !! ** Action  : Get final data in double precision YYYYMMDD.HHMMSS format 
     929      !! ** Purpose : Get initial date in double precision YYYYMMDD.HHMMSS format 
     930      !! 
     931      !! ** Method  :  
     932      !! 
     933      !! ** Action  :  
    1528934      !! 
    1529935      !! History : 
    … …  
    1532938      !!        !  06-10  (A. Weaver) Cleaning 
    1533939      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2 
    1534       !!---------------------------------------------------------------------- 
    1535       USE phycst, ONLY : &            ! Physical constants 
    1536          & rday 
    1537 !      USE daymod, ONLY : &            ! Time variables 
    1538 !         & nmonth_len                 
    1539       USE dom_oce, ONLY : &           ! Ocean space and time domain variables 
    1540          & rdt 
     940      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date 
     941      !!---------------------------------------------------------------------- 
    1541942 
    1542943      IMPLICIT NONE 
    1543944 
    1544945      !! * Arguments 
    1545       REAL(KIND=dp), INTENT(OUT) :: ddobsfin                   ! Final date in YYYYMMDD.HHMMSS 
    1546  
    1547       !! * Local declarations 
    1548       INTEGER :: iyea        ! date - (year, month, day, hour, minute) 
    1549       INTEGER :: imon 
    1550       INTEGER :: iday 
    1551       INTEGER :: ihou 
    1552       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              
    1558       !----------------------------------------------------------------------- 
    1559       ! Initial date initialization (year, month, day, hour, minute) 
    1560       ! (This assumes that the initial date is for 00z) 
    1561       !----------------------------------------------------------------------- 
    1562       iyea =   ndate0 / 10000 
    1563       imon = ( ndate0 - iyea * 10000 ) / 100 
    1564       iday =   ndate0 - iyea * 10000 - imon * 100 
    1565       ihou = 0 
    1566       imin = 0 
    1567        
    1568       !----------------------------------------------------------------------- 
    1569       ! Compute number of days + number of hours + min since initial time 
    1570       !----------------------------------------------------------------------- 
    1571       iday    = iday +  nitend  * rdt / rday 
    1572       zdayfrc =  nitend  * rdt / rday 
    1573       zdayfrc = zdayfrc - AINT( zdayfrc ) 
    1574       ihou    = INT( zdayfrc * 24 ) 
    1575       imin    = INT( ( zdayfrc * 24 - ihou ) * 60 ) 
    1576  
    1577       !----------------------------------------------------------------------- 
    1578       ! Convert number of days (iday) into a real date 
    1579       !---------------------------------------------------------------------- 
    1580  
    1581       CALL calc_month_len( iyea, imonth_len ) 
    1582        
    1583       DO WHILE ( iday > imonth_len(imon) ) 
    1584          iday = iday - imonth_len(imon) 
    1585          imon = imon + 1  
    1586          IF ( imon > 12 ) THEN 
    1587             imon = 1 
    1588             iyea = iyea + 1 
    1589             CALL calc_month_len( iyea, imonth_len )  ! update month lengths 
    1590          ENDIF 
    1591       END DO 
    1592  
    1593       !----------------------------------------------------------------------- 
    1594       ! Convert it into YYYYMMDD.HHMMSS format 
    1595       !----------------------------------------------------------------------- 
    1596       ddobsfin = iyea * 10000_dp + imon * 100_dp    + iday & 
    1597          &     + ihou * 0.01_dp  + imin * 0.0001_dp 
    1598  
    1599     END SUBROUTINE fin_date 
    1600      
     946      REAL(KIND=dp), INTENT(OUT) :: ddobsini                   ! Initial date in YYYYMMDD.HHMMSS 
     947 
     948      CALL calc_date( nit000 - 1, ddobsini ) 
     949 
     950   END SUBROUTINE ini_date 
     951 
     952   SUBROUTINE fin_date( ddobsfin ) 
     953      !!---------------------------------------------------------------------- 
     954      !!                    ***  ROUTINE fin_date  *** 
     955      !!           
     956      !! ** Purpose : Get final date in double precision YYYYMMDD.HHMMSS format 
     957      !! 
     958      !! ** Method  :  
     959      !! 
     960      !! ** Action  :  
     961      !! 
     962      !! History : 
     963      !!        !  06-03  (K. Mogensen)  Original code 
     964      !!        !  06-05  (K. Mogensen)  Reformatted 
     965      !!        !  06-10  (A. Weaver) Cleaning 
     966      !!        !  10-05  (D. Lea) Update to month length calculation for NEMO vn3.2 
     967      !!        !  2014-09  (D. Lea) Change to call generic routine calc_date 
     968      !!---------------------------------------------------------------------- 
     969 
     970      IMPLICIT NONE 
     971 
     972      !! * Arguments 
     973      REAL(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS 
     974 
     975      CALL calc_date( nitend, ddobsfin ) 
     976 
     977   END SUBROUTINE fin_date 
     978    
    1601979END MODULE diaobs 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_fbm.F90

    r4245 r6069  
    4545   INTEGER, PARAMETER    :: fbimdi = -99999   !: Integers 
    4646   REAL(fbsp), PARAMETER :: fbrmdi =  99999   !: Reals 
    47  
    48    ! Output stream choice 
    49    LOGICAL               :: ln_cl4 = .FALSE.  !: Logical switch for 
    50                                               !: class 4 file outputs 
    5147  
    5248   ! Main data structure for observation feedback data. 
    … …  
    10301026 
    10311027   SUBROUTINE write_obfbdata( cdfilename, fbdata ) 
    1032       !!---------------------------------------------------------------------- 
    1033       !!                    ***  ROUTINE write_obfbdata  *** 
    1034       !! 
    1035       !! ** Purpose :   Write an obfbdata structure into a netCDF file. 
    1036       !! 
    1037       !! ** Method  :   Decides which output wrapper to use.  
    1038       !! 
    1039       !! ** Action  :  
    1040       !! 
    1041       !!---------------------------------------------------------------------- 
    1042       !! * Arguments 
    1043       CHARACTER(len=*) :: cdfilename ! Output filename 
    1044       TYPE(obfbdata)   :: fbdata     ! obsfbdata structure 
    1045 #if defined key_offobsoper 
    1046       IF (ln_cl4) THEN 
    1047           ! Class 4 file output stream 
    1048           CALL write_obfbdata_cl( cdfilename, fbdata ) 
    1049       ELSE 
    1050 #endif 
    1051           ! Standard feedback file output stream 
    1052           CALL write_obfbdata_fb( cdfilename, fbdata ) 
    1053 #if defined key_offobsoper 
    1054       ENDIF 
    1055 #endif 
    1056    END SUBROUTINE write_obfbdata 
    1057  
    1058    SUBROUTINE write_obfbdata_fb( cdfilename, fbdata ) 
    10591028      !!---------------------------------------------------------------------- 
    10601029      !!                    ***  ROUTINE write_obfbdata  *** 
    … …  
    15551524 
    15561525       
    1557    END SUBROUTINE write_obfbdata_fb 
    1558  
    1559 #if defined key_offobsoper 
    1560    SUBROUTINE write_obfbdata_cl(cdfilename, fbdata) 
    1561       !!---------------------------------------------------------------------- 
    1562       !!                    ***  ROUTINE write_obfbdata_cl  *** 
    1563       !! 
    1564       !! ** Purpose : Write an obfbdata structure into a class 4 file. 
    1565       !! 
    1566       !! ** Method  : 1. Allocate memory needed by ooo_write 
    1567       !!              2. Map obfbdata into allocated memory 
    1568       !!              3. Pass mapped data to ooo_write 
    1569       !!              4. Deallocate memory 
    1570       !!---------------------------------------------------------------------- 
    1571       USE dom_oce, ONLY: narea 
    1572       USE ooo_write 
    1573       USE ooo_data 
    1574       !! * Arguments 
    1575       CHARACTER(len=*) :: cdfilename ! Feedback filename 
    1576       TYPE(obfbdata)   :: fbdata     ! obsfbdata structure 
    1577       !! * Local variables 
    1578       CHARACTER(len=17), PARAMETER :: cpname = 'write_obfbdata_cl' 
    1579       CHARACTER(len=64) :: & 
    1580               & cdate, &   !: class 4 file validity date  
    1581               & cconf, &   !: model configuration 
    1582               & csys, &    !: model system 
    1583               & ccont, &   !: contact email 
    1584               & cinst, &   !: institution 
    1585               & cversion   !: model version 
    1586       CHARACTER(len=8) :: & 
    1587               & ckind      !: observation kind 
    1588       CHARACTER(len=3) :: cfield 
    1589       INTEGER :: kobs, &   !: number of observations 
    1590               &  kvars, &  !: number of physical variables 
    1591               &  kdeps, &  !: number of observed depths 
    1592               &  kfcst, &  !: number of forecasts 
    1593               &  kifcst, & !: current forecast number 
    1594               &  kproc     !: processor number 
    1595       INTEGER, DIMENSION(:, :, :), ALLOCATABLE :: & 
    1596               &  kqc       !: quality control counterpart 
    1597       INTEGER(KIND=2), DIMENSION(:, :, :), ALLOCATABLE :: & 
    1598               &  k2qc       !: quality control counterpart 
    1599       REAL(kind=fbdp) :: & 
    1600               &  pmodjuld  !: model Julian day 
    1601       REAL(kind=fbdp), DIMENSION(:), ALLOCATABLE :: & 
    1602               &  plead, &  !: forecast lead time 
    1603               &  plam, &   !: longitude of observation 
    1604               &  pphi, &   !: latitude of observation 
    1605               &  ptim      !: time of observation 
    1606       REAL(kind=fbdp), DIMENSION(:, :), ALLOCATABLE :: & 
    1607               &  pdep      !: depths of observations 
    1608       REAL(kind=fbdp), DIMENSION(:, :, :), ALLOCATABLE :: & 
    1609               &  pob, &    !: observation counterpart 
    1610               &  pextra    !: extra field counterpart 
    1611       REAL(kind=fbdp), DIMENSION(:, :, :), ALLOCATABLE :: & 
    1612               &  pmod      !: model counterpart 
    1613       CHARACTER(len=128) :: & 
    1614               &  clfilename  !: class 4 file name 
    1615       CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: & 
    1616               &  ctype       !: Instrument type 
    1617       CHARACTER(len=nf90_max_name) :: & 
    1618               & cdtmp        !: NetCDF variable name 
    1619       CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: & 
    1620               &  cwmo, &     !: Instrument WMO ID 
    1621               &  cunit, &    !: Instrument WMO ID 
    1622               &  cvarname    !: Instrument WMO ID 
    1623       INTEGER :: & 
    1624               &  idep, &     !: Loop variable 
    1625               &  ivar, &     !: Loop variable 
    1626               &  iobs, &     !: Loop variable 
    1627               &  ii, &       !: Loop variable 
    1628               &  ij, &       !: Loop variable 
    1629               &  ik, &       !: Loop variable 
    1630               &  il          !: Loop variable 
    1631       cconf = TRIM(cl4_cfg) 
    1632       csys = TRIM(cl4_sys) 
    1633       cversion = TRIM(cl4_vn) 
    1634       ccont = TRIM(cl4_contact) 
    1635       cinst = TRIM(cl4_inst) 
    1636       cdate = TRIM(cl4_date) 
    1637       CALL locate_kind(cdfilename, ckind) 
    1638       kproc = narea 
    1639       kfcst = cl4_fcst_len 
    1640       kobs = fbdata%nobs 
    1641       kdeps = fbdata%nlev 
    1642       kvars = fbdata%nvar 
    1643       IF (kobs .GT. 0) THEN 
    1644          ALLOCATE(plam(kobs), & 
    1645                &  pphi(kobs), & 
    1646                &  ptim(kobs), & 
    1647                &  plead(kfcst), & 
    1648                &  pdep(kdeps, kobs), & 
    1649                &  kqc(kdeps, kvars, kobs), & 
    1650                &  k2qc(kdeps, kvars, kobs), & 
    1651                &  pob(kdeps, kvars, kobs), & 
    1652                &  pmod(kdeps, kvars, kobs), & 
    1653                &  pextra(kdeps, kvars, kobs), & 
    1654                &  ctype(kobs), & 
    1655                &  cwmo(kobs), & 
    1656                &  cunit(kvars), & 
    1657                &  cvarname(kvars)) 
    1658          plam(:) = fbdata%plam(:) 
    1659          pphi(:) = fbdata%pphi(:) 
    1660          ptim(:) = fbdata%ptim(:) 
    1661          pdep(:, :) = fbdata%pdep(:, :) 
    1662          kqc(:,:,:) = 1. 
    1663          DO ii = 1, kvars 
    1664             cvarname(ii)  = fbdata%cname(ii) 
    1665             cunit(ii)     = fbdata%cobunit(ii) 
    1666          END DO 
    1667  
    1668          ! Quality control algorithm 
    1669          k2qc(:,:,:) = NF90_FILL_SHORT 
    1670          DO idep = 1,kdeps 
    1671             DO ivar = 1, kvars 
    1672                DO iobs = 1, kobs 
    1673                   ! 1 symbolises good for fbdata 
    1674                   ! fbimdi symbolises that qc has not been set 
    1675                   ! Essentially, if any fbdata flag is not an element of {1, fbimdi} 
    1676                   ! then set the class 4 flag to bad. 
    1677                   ! Note: fbdata%ioqc is marked good if zero. 
    1678                   IF (((fbdata%ioqc(iobs) /= 0) .AND. & 
    1679                             & (fbdata%ioqc(iobs) /= fbimdi)) .OR. & 
    1680                     & ((fbdata%ipqc(iobs) /= 1) .AND. & 
    1681                             & (fbdata%ipqc(iobs) /= fbimdi)) .OR. & 
    1682                     & ((fbdata%idqc(idep,iobs) /= 1) .AND. & 
    1683                             & (fbdata%idqc(idep,iobs) /= fbimdi)) .OR. & 
    1684                     & ((fbdata%ivqc(iobs,ivar) /= 1) .AND. & 
    1685                             & (fbdata%ivqc(iobs,ivar) /= fbimdi)) .OR. & 
    1686                     & ((fbdata%ivlqc(idep,iobs,ivar) /= 1) .AND. & 
    1687                             & (fbdata%ivlqc(idep,iobs,ivar) /= fbimdi)) .OR. & 
    1688                     & ((fbdata%itqc(iobs) /= 1) .AND. & 
    1689                             & (fbdata%itqc(iobs) /= fbimdi))) THEN 
    1690                      ! 1 symbolises bad for class 4 file 
    1691                      k2qc(idep, ivar, iobs) = 1 
    1692                   ELSE 
    1693                      ! 0 symbolises good for class 4 file 
    1694                      k2qc(idep, ivar, iobs) = 0 
    1695                   END IF  
    1696                END DO 
    1697             END DO 
    1698          END DO 
    1699  
    1700          ! Permute observation dimensions 
    1701          pob(:,:,:) = RESHAPE(fbdata%pob, (/kdeps, kvars, kobs/), & 
    1702                             & ORDER=(/1, 3, 2/)) 
    1703  
    1704          ! Explicit model counterpart dimension permutation 
    1705          ! 1,2,3,4 --> 1,4,2,3 
    1706          pmod(:,:,:) = fbrmdi 
    1707          ij = cl4_fcst_idx(jimatch) 
    1708          DO ii = 1,kdeps 
    1709             DO ik = 1, kvars 
    1710                DO il = 1, kobs 
    1711                   pmod(ii,ik,il) = fbdata%padd(ii,il,1,ik) 
    1712                END DO 
    1713             END DO 
    1714          END DO 
    1715  
    1716          ! Extra fields set to missing for now 
    1717          pextra(:,:,:) = fbrmdi 
    1718  
    1719          ! Lead time of class 4 file is a global parameter 
    1720          plead = cl4_leadtime(1:cl4_fcst_len) 
    1721  
    1722          ! Model Julian day 
    1723          pmodjuld = cl4_modjuld 
    1724  
    1725          ! Observation types 
    1726          ctype(:) = 'X' 
    1727          DO ii = 1,kobs 
    1728             ctype(ii) = fbdata%cdtyp(ii) 
    1729          END DO 
    1730  
    1731          ! World Meteorology Organisation codes 
    1732          cwmo(:) = fbdata%cdwmo(:) 
    1733  
    1734          ! Initialise class 4 file 
    1735          CALL ooo_wri_init(cconf, csys, ckind, cversion, ccont, cinst, cdate, & 
    1736                          & kproc, kobs, kvars, kdeps, kfcst, & 
    1737                          & clfilename) 
    1738  
    1739          ! Write standard variables 
    1740          CALL ooo_wri_default(clfilename, kobs, kvars, kfcst, kdeps, & 
    1741                             & ctype, cwmo, cunit, cvarname, & 
    1742                             & plam, pphi, pdep, ptim, pob, plead, & 
    1743                             & k2qc, pmodjuld) 
    1744          !! Write to optional variables 
    1745          cdtmp = cl4_vars(jimatch) 
    1746          IF ( (TRIM(cdtmp) == "forecast") .OR. & 
    1747               (TRIM(cdtmp) == "persistence") ) THEN 
    1748             !! 4D variables 
    1749             CALL ooo_wri_extra(clfilename, TRIM(cdtmp), kdeps, kfcst, & 
    1750                             &  kvars, kobs, (/ 1,ij,1,1 /), (/ kdeps,1,kvars,kobs /), pmod) 
    1751          ELSE 
    1752             !! 3D variables 
    1753             CALL ooo_wri_extra(clfilename, TRIM(cdtmp), kdeps, & 
    1754                             &  kvars, kobs, (/ 1,1,1 /), (/ kdeps,kvars,kobs /), pmod) 
    1755          ENDIF 
    1756  
    1757          DEALLOCATE(plam, pphi, ptim, pdep, plead, kqc, k2qc, & 
    1758                   & pob, pmod, pextra, ctype, cwmo, & 
    1759                   & cunit, cvarname) 
    1760       END IF 
    1761    END SUBROUTINE write_obfbdata_cl 
    1762 #endif 
    1763  
    1764 #if defined key_offobsoper 
    1765    SUBROUTINE locate_kind(cdfilename, ckind) 
    1766       !!---------------------------------------------------------------------- 
    1767       !!                    ***  ROUTINE locate_kind  *** 
    1768       !! 
    1769       !! ** Purpose : Detect which kind of class 4 file is being produced. 
    1770       !! 
    1771       !! ** Method  : 1. Inspect cdfilename for observation kind. 
    1772       !!---------------------------------------------------------------------- 
    1773       CHARACTER(len=*) :: cdfilename ! Feedback filename 
    1774       CHARACTER(len=8) :: ckind 
    1775       IF (cdfilename(1:3) == 'sst') THEN 
    1776          ckind = 'SST' 
    1777       ELSE IF (cdfilename(1:3) == 'sla') THEN 
    1778          ckind = 'SLA' 
    1779       ELSE IF (cdfilename(1:3) == 'pro') THEN 
    1780          ckind = 'profile' 
    1781       ELSE IF (cdfilename(1:3) == 'ena') THEN 
    1782          ckind = 'profile' 
    1783       ELSE IF (cdfilename(1:3) == 'sea') THEN 
    1784          ckind = 'seaice' 
    1785       ELSE 
    1786          ckind = 'unknown' 
    1787       END IF 
    1788    END SUBROUTINE locate_kind 
    1789 #endif 
     1526   END SUBROUTINE write_obfbdata 
    17901527 
    17911528   SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, & 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grd_bruteforce.h90

    r2358 r6069  
    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/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grid.F90

    r4990 r6069  
    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/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_inter_sup.F90

    r3294 r6069  
    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/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90

    r2513 r6069  
    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 
    … …  
    111113 
    112114 
    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 
     115   SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) 
     116      !!---------------------------------------------------------------------- 
     117      !!               ***  ROUTINE obs_mpp_find_obs_proc  *** 
     118      !!          
     119      !! ** Purpose : From the array kobsp containing the results of the 
    118120      !!              grid search on each processor the processor return a 
    119121      !!              decision of which processors should hold the observation. 
    120122      !! 
    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.  
     123      !! ** Method  : Synchronize the processor number for each obs using 
     124      !!              obs_mpp_max_integer. If an observation exists on two  
     125      !!              processors it will be allocated to the lower numbered 
     126      !!              processor. 
     127      !! 
     128      !! ** Action  : This does only work for MPI. 
    127129      !!              It does not work for SHMEM. 
    128130      !! 
    … …  
    130132      !!---------------------------------------------------------------------- 
    131133      INTEGER                , INTENT(in   ) ::   kno 
    132       INTEGER, DIMENSION(kno), INTENT(in   ) ::   kobsi, kobsj 
    133134      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp 
    134135      ! 
    135136#if defined key_mpp_mpi 
    136137      ! 
    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       !----------------------------------------------------------------------- 
     138      ! 
     139      INTEGER :: ji, isum 
     140      INTEGER, DIMENSION(kno) ::   iobsp 
     141      !! 
     142      !! 
     143 
     144      iobsp=kobsp 
     145 
     146      WHERE( iobsp(:) == -1 ) 
     147         iobsp(:) = 9999999 
     148      END WHERE 
     149 
     150      iobsp=-1*iobsp 
     151 
     152      CALL obs_mpp_max_integer( iobsp, kno ) 
     153 
     154      kobsp=-1*iobsp 
     155 
     156      isum=0 
    157157      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 
     158         IF ( kobsp(ji) == 9999999 ) THEN 
     159            isum=isum+1 
     160            kobsp(ji)=-1 
    165161         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 ) 
    222       DEALLOCATE( iobsp ) 
     162      ENDDO 
     163 
     164 
     165      IF ( isum > 0 ) THEN 
     166         IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' 
     167         IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' 
     168      ENDIF 
     169 
    223170#else 
    224171      ! no MPI: empty routine 
    225 #endif 
    226       ! 
     172#endif      
     173       
    227174   END SUBROUTINE obs_mpp_find_obs_proc 
    228175 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_oper.F90

    r4245 r6069  
    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 
     11   !!   obs_pro_sco_opt: Compute the model counterpart of temperature and  
     12   !!                    salinity observations from profiles in generalised  
     13   !!                    vertical coordinates  
    2214   !!---------------------------------------------------------------------- 
    2315 
    24    !! * Modules used    
     16   !! * Modules used 
    2517   USE par_kind, ONLY : &         ! Precision variables 
    2618      & wp 
    2719   USE in_out_manager             ! I/O manager 
    2820   USE obs_inter_sup              ! Interpolation support 
    29    USE obs_inter_h2d, ONLY : &    ! Horizontal interpolation to the observation pt 
     21   USE obs_inter_h2d, ONLY : &    ! Horizontal interpolation to the obs pt 
    3022      & obs_int_h2d, & 
    3123      & obs_int_h2d_init 
    32    USE obs_inter_z1d, ONLY : &    ! Vertical interpolation to the observation pt 
     24   USE obs_inter_z1d, ONLY : &    ! Vertical interpolation to the obs pt 
    3325      & obs_int_z1d,    & 
    3426      & obs_int_z1d_spl 
    … …  
    3729   USE dom_oce,       ONLY : & 
    3830      & glamt, glamu, glamv, & 
    39       & gphit, gphiu, gphiv 
     31      & gphit, gphiu, gphiv, &  
     32#if defined key_vvl  
     33      & gdept_n  
     34#else  
     35      & gdept_0  
     36#endif   
    4037   USE lib_mpp,       ONLY : & 
    4138      & ctl_warn, ctl_stop 
     39   USE obs_grid,      ONLY : &  
     40      & obs_level_search      
     41   USE sbcdcy,        ONLY : &    ! For calculation of where it is night-time 
     42      & sbc_dcy, nday_qsr 
    4243 
    4344   IMPLICIT NONE 
    … …  
    4647   PRIVATE 
    4748 
    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 
     49   PUBLIC obs_prof_opt, &  ! Compute the model counterpart of profile obs 
     50      &   obs_pro_sco_opt, &  ! Compute the model counterpart of profile observations  
     51      &   obs_surf_opt     ! Compute the model counterpart of surface obs 
     52 
     53   INTEGER, PARAMETER, PUBLIC :: & 
     54      & imaxavtypes = 20   ! Max number of daily avgd obs types 
    5655 
    5756   !!---------------------------------------------------------------------- 
    … …  
    6160   !!---------------------------------------------------------------------- 
    6261 
     62   !! * Substitutions  
     63#  include "domzgr_substitute.h90"  
    6364CONTAINS 
    6465 
    65    SUBROUTINE obs_pro_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 
    66       &                    ptn, psn, pgdept, ptmask, k1dint, k2dint, & 
    67       &                    kdailyavtypes ) 
     66   SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk,          & 
     67      &                     kit000, kdaystp,                      & 
     68      &                     pvar1, pvar2, pgdept, pmask1, pmask2, & 
     69      &                     plam1, plam2, pphi1, pphi2,           & 
     70      &                     k1dint, k2dint, kdailyavtypes ) 
     71 
    6872      !!----------------------------------------------------------------------- 
    6973      !! 
    … …  
    7882      !! 
    7983      !!    First, a vertical profile of horizontally interpolated model 
    80       !!    now temperatures is computed at the obs (lon, lat) point. 
     84      !!    now values is computed at the obs (lon, lat) point. 
    8185      !!    Several horizontal interpolation schemes are available: 
    8286      !!        - distance-weighted (great circle) (k2dint = 0) 
    … …  
    8690      !!        - polynomial (quadrilateral grid)  (k2dint = 4) 
    8791      !! 
    88       !!    Next, the vertical temperature profile is interpolated to the 
     92      !!    Next, the vertical profile is interpolated to the 
    8993      !!    data depth points. Two vertical interpolation schemes are 
    9094      !!    available: 
    … …  
    96100      !!    routine. 
    97101      !! 
    98       !!    For ENACT moored buoy data (e.g., TAO), the model equivalent is 
     102      !!    If the logical is switched on, the model equivalent is 
    99103      !!    a daily mean model temperature field. So, we first compute 
    100104      !!    the mean, then interpolate only at the end of the day. 
    101105      !! 
    102       !!    Note: the in situ temperature observations must be converted 
     106      !!    Note: in situ temperature observations must be converted 
    103107      !!    to potential temperature (the model variable) prior to 
    104108      !!    assimilation.  
    105       !!?????????????????????????????????????????????????????????????? 
    106       !!    INCLUDE POTENTIAL TEMP -> IN SITU TEMP IN OBS OPERATOR??? 
    107       !!?????????????????????????????????????????????????????????????? 
    108109      !! 
    109110      !! ** Action  : 
    … …  
    115116      !!      ! 07-01 (K. Mogensen) Merge of temperature and salinity 
    116117      !!      ! 07-03 (K. Mogensen) General handling of profiles 
     118      !!      ! 15-02 (M. Martin) Combined routine for all profile types 
    117119      !!----------------------------------------------------------------------- 
    118    
     120 
    119121      !! * Modules used 
    120122      USE obs_profiles_def ! Definition of storage space for profile obs. 
    … …  
    123125 
    124126      !! * 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 
     127      TYPE(obs_prof), INTENT(INOUT) :: & 
     128         & prodatqc                  ! Subset of profile data passing QC 
     129      INTEGER, INTENT(IN) :: kt      ! Time step 
     130      INTEGER, INTENT(IN) :: kpi     ! Model grid parameters 
    128131      INTEGER, INTENT(IN) :: kpj 
    129132      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                     
     133      INTEGER, INTENT(IN) :: kit000  ! Number of the first time step 
     134                                     !   (kit000-1 = restart time) 
     135      INTEGER, INTENT(IN) :: k1dint  ! Vertical interpolation type (see header) 
     136      INTEGER, INTENT(IN) :: k2dint  ! Horizontal interpolation type (see header) 
     137      INTEGER, INTENT(IN) :: kdaystp ! Number of time steps per day 
    135138      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         & pvar1,    &               ! Model field 1 
     140         & pvar2,    &               ! Model field 2 
     141         & pmask1,   &               ! Land-sea mask 1 
     142         & pmask2                    ! Land-sea mask 2 
     143      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
     144         & plam1,    &               ! Model longitudes for variable 1 
     145         & plam2,    &               ! Model longitudes for variable 2 
     146         & pphi1,    &               ! Model latitudes for variable 1 
     147         & pphi2                     ! Model latitudes for variable 2 
    139148      REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 
    140          & pgdept       ! Model array of depth levels 
     149         & pgdept                    ! Model array of depth levels 
    141150      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    142          & kdailyavtypes! Types for daily averages 
     151         & kdailyavtypes             ! Types for daily averages 
     152 
    143153      !! * Local declarations 
    144154      INTEGER ::   ji 
    … …  
    154164      INTEGER, DIMENSION(imaxavtypes) :: & 
    155165         & idailyavtypes 
     166      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
     167         & igrdi1, & 
     168         & igrdi2, & 
     169         & igrdj1, & 
     170         & igrdj2 
    156171      REAL(KIND=wp) :: zlam 
    157172      REAL(KIND=wp) :: zphi 
    158173      REAL(KIND=wp) :: zdaystp 
    159174      REAL(KIND=wp), DIMENSION(kpk) :: & 
    160          & zobsmask, & 
     175         & zobsmask1, & 
     176         & zobsmask2, & 
    161177         & zobsk,    & 
    162178         & zobs2k 
    163179      REAL(KIND=wp), DIMENSION(2,2,kpk) :: & 
    164          & zweig 
     180         & zweig1, & 
     181         & zweig2 
    165182      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
    166          & zmask, & 
    167          & zintt, & 
    168          & zints, & 
    169          & zinmt, & 
    170          & zinms 
     183         & zmask1, & 
     184         & zmask2, & 
     185         & zint1, & 
     186         & zint2, & 
     187         & zinm1, & 
     188         & zinm2 
    171189      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    172          & zglam, & 
    173          & zgphi 
    174       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    175          & igrdi, & 
    176          & igrdj 
     190         & zglam1, & 
     191         & zglam2, & 
     192         & zgphi1, & 
     193         & zgphi2 
     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,1) = 0.0 
     224                     prodatqc%vdmean(ji,jj,jk,2) = 0.0 
     225                  END DO 
     226               END DO 
     227            END DO 
     228         ENDIF 
     229 
    198230         DO jk = 1, jpk 
    199231            DO jj = 1, jpj 
    200232               DO ji = 1, jpi 
    201                   prodatqc%vdmean(ji,jj,jk,1) = 0.0 
    202                   prodatqc%vdmean(ji,jj,jk,2) = 0.0 
     233                  ! Increment field 1 for computing daily mean 
     234                  prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
     235                     &                        + pvar1(ji,jj,jk) 
     236                  ! Increment field 2 for computing daily mean 
     237                  prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
     238                     &                        + pvar2(ji,jj,jk) 
    203239               END DO 
    204240            END DO 
    205241         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 
     242 
     243         ! Compute the daily mean at the end of day 
     244         zdaystp = 1.0 / REAL( kdaystp ) 
     245         IF ( idayend == 0 ) THEN 
     246            IF (lwp) WRITE(numout,*) 'Calculating prodatqc%vdmean on time-step: ',kt 
     247            CALL FLUSH(numout) 
     248            DO jk = 1, jpk 
     249               DO jj = 1, jpj 
     250                  DO ji = 1, jpi 
     251                     prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
     252                        &                        * zdaystp 
     253                     prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
     254                        &                        * zdaystp 
     255                  END DO 
    231256               END DO 
    232257            END DO 
    233          END DO 
     258         ENDIF 
     259 
    234260      ENDIF 
    235261 
    236262      ! Get the data for interpolation 
    237263      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)   & 
     264         & igrdi1(2,2,ipro),      & 
     265         & igrdi2(2,2,ipro),      & 
     266         & igrdj1(2,2,ipro),      & 
     267         & igrdj2(2,2,ipro),      & 
     268         & zglam1(2,2,ipro),      & 
     269         & zglam2(2,2,ipro),      & 
     270         & zgphi1(2,2,ipro),      & 
     271         & zgphi2(2,2,ipro),      & 
     272         & zmask1(2,2,kpk,ipro),  & 
     273         & zmask2(2,2,kpk,ipro),  & 
     274         & zint1(2,2,kpk,ipro),  & 
     275         & zint2(2,2,kpk,ipro)   & 
    245276         & ) 
    246277 
    247278      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
    248279         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) 
     280         igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 
     281         igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 
     282         igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 
     283         igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) 
     284         igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) 
     285         igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 
     286         igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) 
     287         igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) 
     288         igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 
     289         igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 
     290         igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 
     291         igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) 
     292         igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) 
     293         igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 
     294         igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) 
     295         igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) 
    257296      END DO 
    258297 
    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 ) 
     298      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) 
     299      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) 
     300      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) 
     301      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1,   zint1 ) 
     302       
     303      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) 
     304      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) 
     305      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) 
     306      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2,   zint2 ) 
    264307 
    265308      ! At the end of the day also get interpolated means 
    266       IF ( idayend == 0 ) THEN 
     309      IF ( ld_dailyav .AND. idayend == 0 ) THEN 
    267310 
    268311         ALLOCATE( & 
    269             & zinmt(2,2,kpk,ipro),  & 
    270             & zinms(2,2,kpk,ipro)   & 
     312            & zinm1(2,2,kpk,ipro),  & 
     313            & zinm2(2,2,kpk,ipro)   & 
    271314            & ) 
    272315 
    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 ) 
     316         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & 
     317            &                  prodatqc%vdmean(:,:,:,1), zinm1 ) 
     318         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & 
     319            &                  prodatqc%vdmean(:,:,:,2), zinm2 ) 
    277320 
    278321      ENDIF 
    … …  
    283326 
    284327         IF ( kt /= prodatqc%mstp(jobs) ) THEN 
    285              
     328 
    286329            IF(lwp) THEN 
    287330               WRITE(numout,*) 
    … …  
    298341            CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 
    299342         ENDIF 
    300           
     343 
    301344         zlam = prodatqc%rlam(jobs) 
    302345         zphi = prodatqc%rphi(jobs) 
    303           
     346 
    304347         ! Horizontal weights and vertical mask 
    305348 
    306          IF ( ( prodatqc%npvend(jobs,1) > 0 ) .OR. & 
    307             & ( prodatqc%npvend(jobs,2) > 0 ) ) THEN 
     349         IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 
    308350 
    309351            CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi,     & 
    310                &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
    311                &                   zmask(:,:,:,iobs), zweig, zobsmask ) 
     352               &                   zglam1(:,:,iobs), zgphi1(:,:,iobs), & 
     353               &                   zmask1(:,:,:,iobs), zweig1, zobsmask1 ) 
    312354 
    313355         ENDIF 
    314356 
     357         IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
     358 
     359            CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi,     & 
     360               &                   zglam2(:,:,iobs), zgphi2(:,:,iobs), & 
     361               &                   zmask2(:,:,:,iobs), zweig2, zobsmask2 ) 
     362  
     363         ENDIF 
     364 
    315365         IF ( prodatqc%npvend(jobs,1) > 0 ) THEN 
    316366 
    317367            zobsk(:) = obfillflt 
    318368 
    319        IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
     369            IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
    320370 
    321371               IF ( idayend == 0 )  THEN 
    322                    
    323                   ! Daily averaged moored buoy (MRB) data 
    324                    
     372                  ! Daily averaged data 
    325373                  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' ) 
     374                     &              zweig1, zinm1(:,:,:,iobs), zobsk ) 
    334375 
    335376               ENDIF 
    336            
     377 
    337378            ELSE  
    338                 
     379 
    339380               ! Point data 
    340  
    341381               CALL obs_int_h2d( kpk, kpk,      & 
    342                   &              zweig, zintt(:,:,:,iobs), zobsk ) 
     382                  &              zweig1, zint1(:,:,:,iobs), zobsk ) 
    343383 
    344384            ENDIF 
    … …  
    348388            ! polynomial at obs points 
    349389            !------------------------------------------------------------- 
    350              
     390 
    351391            IF ( k1dint == 1 ) THEN 
    352392               CALL obs_int_z1d_spl( kpk, zobsk, zobs2k,   & 
    353                   &                  pgdept, zobsmask ) 
     393                  &                  pgdept, zobsmask1 ) 
    354394            ENDIF 
    355              
     395 
    356396            !----------------------------------------------------------------- 
    357397            !  Vertical interpolation to the observation point 
    … …  
    365405               & zobsk, zobs2k,                   & 
    366406               & prodatqc%var(1)%vmod(ista:iend), & 
    367                & pgdept, zobsmask ) 
     407               & pgdept, zobsmask1 ) 
    368408 
    369409         ENDIF 
    … …  
    377417               IF ( idayend == 0 )  THEN 
    378418 
    379                   ! Daily averaged moored buoy (MRB) data 
    380                    
     419                  ! Daily averaged data 
    381420                  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' ) 
     421                     &              zweig2, zinm2(:,:,:,iobs), zobsk ) 
    389422 
    390423               ENDIF 
    391424 
    392425            ELSE 
    393                 
     426 
    394427               ! Point data 
    395  
    396428               CALL obs_int_h2d( kpk, kpk,      & 
    397                   &              zweig, zints(:,:,:,iobs), zobsk ) 
     429                  &              zweig2, zint2(:,:,:,iobs), zobsk ) 
    398430 
    399431            ENDIF 
    … …  
    404436            ! polynomial at obs points 
    405437            !------------------------------------------------------------- 
    406              
     438 
    407439            IF ( k1dint == 1 ) THEN 
    408440               CALL obs_int_z1d_spl( kpk, zobsk, zobs2k, & 
    409                   &                  pgdept, zobsmask ) 
     441                  &                  pgdept, zobsmask2 ) 
    410442            ENDIF 
    411              
     443 
    412444            !---------------------------------------------------------------- 
    413445            !  Vertical interpolation to the observation point 
    … …  
    421453               & zobsk, zobs2k, & 
    422454               & prodatqc%var(2)%vmod(ista:iend),& 
    423                & pgdept, zobsmask ) 
     455               & pgdept, zobsmask2 ) 
    424456 
    425457         ENDIF 
    426458 
    427459      END DO 
    428   
     460 
    429461      ! Deallocate the data for interpolation 
    430462      DEALLOCATE( & 
    431          & igrdi, & 
    432          & igrdj, & 
    433          & zglam, & 
    434          & zgphi, & 
    435          & zmask, & 
    436          & zintt, & 
    437          & zints  & 
     463         & igrdi1, & 
     464         & igrdi2, & 
     465         & igrdj1, & 
     466         & igrdj2, & 
     467         & zglam1, & 
     468         & zglam2, & 
     469         & zgphi1, & 
     470         & zgphi2, & 
     471         & zmask1, & 
     472         & zmask2, & 
     473         & zint1,  & 
     474         & zint2   & 
    438475         & ) 
     476 
    439477      ! At the end of the day also get interpolated means 
    440       IF ( idayend == 0 ) THEN 
     478      IF ( ld_dailyav .AND. idayend == 0 ) THEN 
    441479         DEALLOCATE( & 
    442             & zinmt,  & 
    443             & zinms   & 
     480            & zinm1,  & 
     481            & zinm2   & 
    444482            & ) 
    445483      ENDIF 
    446484 
    447485      prodatqc%nprofup = prodatqc%nprofup + ipro  
     486 
     487   END SUBROUTINE obs_prof_opt 
     488 
     489   SUBROUTINE obs_pro_sco_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, &  
     490      &                    ptn, psn, pgdept, pgdepw, ptmask, k1dint, k2dint, &  
     491      &                    kdailyavtypes )  
     492      !!-----------------------------------------------------------------------  
     493      !!  
     494      !!                     ***  ROUTINE obs_pro_opt  ***  
     495      !!  
     496      !! ** Purpose : Compute the model counterpart of profiles  
     497      !!              data by interpolating from the model grid to the   
     498      !!              observation point. Generalised vertical coordinate version  
     499      !!  
     500      !! ** Method  : Linearly interpolate to each observation point using   
     501      !!              the model values at the corners of the surrounding grid box.  
     502      !!  
     503      !!          First, model values on the model grid are interpolated vertically to the  
     504      !!          Depths of the profile observations.  Two vertical interpolation schemes are  
     505      !!          available:  
     506      !!          - linear       (k1dint = 0)  
     507      !!          - Cubic spline (k1dint = 1)     
     508      !!  
     509      !!  
     510      !!         Secondly the interpolated values are interpolated horizontally to the   
     511      !!         obs (lon, lat) point.  
     512      !!         Several horizontal interpolation schemes are available:  
     513      !!        - distance-weighted (great circle) (k2dint = 0)  
     514      !!        - distance-weighted (small angle)  (k2dint = 1)  
     515      !!        - bilinear (geographical grid)     (k2dint = 2)  
     516      !!        - bilinear (quadrilateral grid)    (k2dint = 3)  
     517      !!        - polynomial (quadrilateral grid)  (k2dint = 4)  
     518      !!  
     519      !!    For the cubic spline the 2nd derivative of the interpolating   
     520      !!    polynomial is computed before entering the vertical interpolation   
     521      !!    routine.  
     522      !!  
     523      !!    For ENACT moored buoy data (e.g., TAO), the model equivalent is  
     524      !!    a daily mean model temperature field. So, we first compute  
     525      !!    the mean, then interpolate only at the end of the day.  
     526      !!  
     527      !!    This is the procedure to be used with generalised vertical model   
     528      !!    coordinates (ie s-coordinates. It is ~4x slower than the equivalent  
     529      !!    horizontal then vertical interpolation algorithm, but can deal with situations  
     530      !!    where the model levels are not flat.  
     531      !!    ONLY PERFORMED if ln_sco=.TRUE.   
     532      !!        
     533      !!    Note: the in situ temperature observations must be converted  
     534      !!    to potential temperature (the model variable) prior to  
     535      !!    assimilation.   
     536      !!??????????????????????????????????????????????????????????????  
     537      !!    INCLUDE POTENTIAL TEMP -> IN SITU TEMP IN OBS OPERATOR???  
     538      !!??????????????????????????????????????????????????????????????  
     539      !!  
     540      !! ** Action  :  
     541      !!  
     542      !! History :  
     543      !!      ! 2014-08 (J. While) Adapted from obs_pro_opt to handel generalised  
     544      !!                           vertical coordinates 
     545      !!-----------------------------------------------------------------------  
     546    
     547      !! * Modules used  
     548      USE obs_profiles_def   ! Definition of storage space for profile obs.  
     549      USE dom_oce,  ONLY : &  
     550#if defined key_vvl   
     551      &   gdepw_n  
     552#else  
     553      &   gdepw_0  
     554#endif  
     555        
     556      IMPLICIT NONE  
     557  
     558      !! * Arguments  
     559      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening  
     560      INTEGER, INTENT(IN) :: kt        ! Time step  
     561      INTEGER, INTENT(IN) :: kpi       ! Model grid parameters  
     562      INTEGER, INTENT(IN) :: kpj  
     563      INTEGER, INTENT(IN) :: kpk  
     564      INTEGER, INTENT(IN) :: kit000    ! Number of the first time step   
     565                                       !   (kit000-1 = restart time)  
     566      INTEGER, INTENT(IN) :: k1dint    ! Vertical interpolation type (see header)  
     567      INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header)  
     568      INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day                      
     569      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: &  
     570         & ptn,    &    ! Model temperature field  
     571         & psn,    &    ! Model salinity field  
     572         & ptmask       ! Land-sea mask  
     573      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: &  
     574         & pgdept,  &    ! Model array of depth T levels     
     575         & pgdepw       ! Model array of depth W levels  
     576      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: &  
     577         & kdailyavtypes   ! Types for daily averages  
    448578       
    449    END SUBROUTINE obs_pro_opt 
    450  
    451    SUBROUTINE obs_sla_opt( sladatqc, kt, kpi, kpj, kit000, & 
    452       &                    psshn, psshmask, k2dint ) 
     579      !! * Local declarations  
     580      INTEGER ::   ji  
     581      INTEGER ::   jj  
     582      INTEGER ::   jk  
     583      INTEGER ::   iico, ijco  
     584      INTEGER ::   jobs  
     585      INTEGER ::   inrc  
     586      INTEGER ::   ipro  
     587      INTEGER ::   idayend  
     588      INTEGER ::   ista  
     589      INTEGER ::   iend  
     590      INTEGER ::   iobs  
     591      INTEGER ::   iin, ijn, ikn, ik   ! looping indices over interpolation nodes  
     592      INTEGER, DIMENSION(imaxavtypes) :: &  
     593         & idailyavtypes  
     594      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &  
     595         & igrdi, &  
     596         & igrdj  
     597      INTEGER :: &  
     598         & inum_obs 
     599      INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic     
     600      REAL(KIND=wp) :: zlam  
     601      REAL(KIND=wp) :: zphi  
     602      REAL(KIND=wp) :: zdaystp  
     603      REAL(KIND=wp), DIMENSION(kpk) :: &  
     604         & zobsmask, &  
     605         & zobsk,    &  
     606         & zobs2k  
     607      REAL(KIND=wp), DIMENSION(2,2,1) :: &  
     608         & zweig, &  
     609         & l_zweig  
     610      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: &  
     611         & zmask, &  
     612         & zintt, &  
     613         & zints, &  
     614         & zinmt, &  
     615         & zgdept,&  
     616         & zgdepw,&  
     617         & zinms  
     618      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: &  
     619         & zglam, &  
     620         & zgphi     
     621      REAL(KIND=wp), DIMENSION(1) :: zmsk_1        
     622      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner        
     623  
     624      !------------------------------------------------------------------------  
     625      ! Local initialization   
     626      !------------------------------------------------------------------------  
     627      ! ... Record and data counters  
     628      inrc = kt - kit000 + 2  
     629      ipro = prodatqc%npstp(inrc)  
     630   
     631      ! Daily average types  
     632      IF ( PRESENT(kdailyavtypes) ) THEN  
     633         idailyavtypes(:) = kdailyavtypes(:)  
     634      ELSE  
     635         idailyavtypes(:) = -1  
     636      ENDIF  
     637  
     638      ! Initialize daily mean for first time-step  
     639      idayend = MOD( kt - kit000 + 1, kdaystp )  
     640  
     641      ! Added kt == 0 test to catch restart case   
     642      IF ( idayend == 1 .OR. kt == 0) THEN  
     643           
     644         IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt  
     645         DO jk = 1, jpk  
     646            DO jj = 1, jpj  
     647               DO ji = 1, jpi  
     648                  prodatqc%vdmean(ji,jj,jk,1) = 0.0  
     649                  prodatqc%vdmean(ji,jj,jk,2) = 0.0  
     650               END DO  
     651            END DO  
     652         END DO  
     653        
     654      ENDIF  
     655        
     656      DO jk = 1, jpk  
     657         DO jj = 1, jpj  
     658            DO ji = 1, jpi  
     659               ! Increment the temperature field for computing daily mean  
     660               prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) &  
     661               &                        + ptn(ji,jj,jk)  
     662               ! Increment the salinity field for computing daily mean  
     663               prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) &  
     664               &                        + psn(ji,jj,jk)  
     665            END DO  
     666         END DO  
     667      END DO  
     668     
     669      ! Compute the daily mean at the end of day  
     670      zdaystp = 1.0 / REAL( kdaystp )  
     671      IF ( idayend == 0 ) THEN  
     672         DO jk = 1, jpk  
     673            DO jj = 1, jpj  
     674               DO ji = 1, jpi  
     675                  prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) &  
     676                  &                        * zdaystp  
     677                  prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) &  
     678                  &                           * zdaystp  
     679               END DO  
     680            END DO  
     681         END DO  
     682      ENDIF  
     683  
     684      ! Get the data for interpolation  
     685      ALLOCATE( &  
     686         & igrdi(2,2,ipro),      &  
     687         & igrdj(2,2,ipro),      &  
     688         & zglam(2,2,ipro),      &  
     689         & zgphi(2,2,ipro),      &  
     690         & zmask(2,2,kpk,ipro),  &  
     691         & zintt(2,2,kpk,ipro),  &  
     692         & zints(2,2,kpk,ipro),  &  
     693         & zgdept(2,2,kpk,ipro), &  
     694         & zgdepw(2,2,kpk,ipro)  &  
     695         & )  
     696  
     697      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro  
     698         iobs = jobs - prodatqc%nprofup  
     699         igrdi(1,1,iobs) = prodatqc%mi(jobs,1)-1  
     700         igrdj(1,1,iobs) = prodatqc%mj(jobs,1)-1  
     701         igrdi(1,2,iobs) = prodatqc%mi(jobs,1)-1  
     702         igrdj(1,2,iobs) = prodatqc%mj(jobs,1)  
     703         igrdi(2,1,iobs) = prodatqc%mi(jobs,1)  
     704         igrdj(2,1,iobs) = prodatqc%mj(jobs,1)-1  
     705         igrdi(2,2,iobs) = prodatqc%mi(jobs,1)  
     706         igrdj(2,2,iobs) = prodatqc%mj(jobs,1)  
     707      END DO  
     708      
     709      ! Initialise depth arrays 
     710      zgdept = 0.0 
     711      zgdepw = 0.0 
     712  
     713      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, glamt, zglam )  
     714      CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi, igrdj, gphit, zgphi )  
     715      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, ptmask,zmask )  
     716      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, ptn,   zintt )  
     717      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, psn,   zints )  
     718      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdept(:,:,:), &  
     719        &                     zgdept )  
     720      CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, pgdepw(:,:,:), &  
     721        &                     zgdepw )  
     722  
     723      ! At the end of the day also get interpolated means  
     724      IF ( idayend == 0 ) THEN  
     725  
     726         ALLOCATE( &  
     727            & zinmt(2,2,kpk,ipro),  &  
     728            & zinms(2,2,kpk,ipro)   &  
     729            & )  
     730  
     731         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, &  
     732            &                  prodatqc%vdmean(:,:,:,1), zinmt )  
     733         CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi, igrdj, &  
     734            &                  prodatqc%vdmean(:,:,:,2), zinms )  
     735  
     736      ENDIF  
     737        
     738      ! Return if no observations to process  
     739      ! Has to be done after comm commands to ensure processors  
     740      ! stay in sync  
     741      IF ( ipro == 0 ) RETURN  
     742  
     743      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro  
     744     
     745         iobs = jobs - prodatqc%nprofup  
     746     
     747         IF ( kt /= prodatqc%mstp(jobs) ) THEN  
     748              
     749            IF(lwp) THEN  
     750               WRITE(numout,*)  
     751               WRITE(numout,*) ' E R R O R : Observation',              &  
     752                  &            ' time step is not consistent with the', &  
     753                  &            ' model time step'  
     754               WRITE(numout,*) ' ========='  
     755               WRITE(numout,*)  
     756               WRITE(numout,*) ' Record  = ', jobs,                    &  
     757                  &            ' kt      = ', kt,                      &  
     758                  &            ' mstp    = ', prodatqc%mstp(jobs), &  
     759                  &            ' ntyp    = ', prodatqc%ntyp(jobs)  
     760            ENDIF  
     761            CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' )  
     762         ENDIF  
     763           
     764         zlam = prodatqc%rlam(jobs)  
     765         zphi = prodatqc%rphi(jobs)  
     766           
     767         ! Horizontal weights  
     768         ! Only calculated once, for both T and S.  
     769         ! Masked values are calculated later.   
     770  
     771         IF ( ( prodatqc%npvend(jobs,1) > 0 ) .OR. &  
     772            & ( prodatqc%npvend(jobs,2) > 0 ) ) THEN  
     773  
     774            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     &  
     775               &                   zglam(:,:,iobs), zgphi(:,:,iobs), &  
     776               &                   zmask(:,:,1,iobs), zweig, zmsk_1 )  
     777  
     778         ENDIF  
     779          
     780         ! IF zmsk_1 = 0; then ob is on land  
     781         IF (zmsk_1(1) < 0.1) THEN  
     782            WRITE(numout,*) 'WARNING (obs_oper) :- profile found within landmask'  
     783    
     784         ELSE   
     785              
     786            ! Temperature  
     787              
     788            IF ( prodatqc%npvend(jobs,1) > 0 ) THEN   
     789     
     790               zobsk(:) = obfillflt  
     791     
     792               IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN  
     793     
     794                  IF ( idayend == 0 )  THEN  
     795                    
     796                     ! Daily averaged moored buoy (MRB) data  
     797                    
     798                     ! vertically interpolate all 4 corners  
     799                     ista = prodatqc%npvsta(jobs,1)  
     800                     iend = prodatqc%npvend(jobs,1)  
     801                     inum_obs = iend - ista + 1  
     802                     ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs))  
     803       
     804                     DO iin=1,2  
     805                        DO ijn=1,2  
     806                                        
     807                                        
     808            
     809                           IF ( k1dint == 1 ) THEN  
     810                              CALL obs_int_z1d_spl( kpk, &  
     811                                 &     zinmt(iin,ijn,:,iobs), &  
     812                                 &     zobs2k, zgdept(iin,ijn,:,iobs), &  
     813                                 &     zmask(iin,ijn,:,iobs))  
     814                           ENDIF  
     815        
     816                           CALL obs_level_search(kpk, &  
     817                              &    zgdept(iin,ijn,:,iobs), &  
     818                              &    inum_obs, prodatqc%var(1)%vdep(ista:iend), &  
     819                              &    iv_indic)  
     820                           CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, &  
     821                              &    prodatqc%var(1)%vdep(ista:iend), &  
     822                              &    zinmt(iin,ijn,:,iobs), &  
     823                              &    zobs2k, interp_corner(iin,ijn,:), &  
     824                              &    zgdept(iin,ijn,:,iobs), &  
     825                              &    zmask(iin,ijn,:,iobs))  
     826        
     827                        ENDDO  
     828                     ENDDO  
     829                    
     830                    
     831                  ELSE  
     832                 
     833                     CALL ctl_stop( ' A nonzero' //     &  
     834                        &           ' number of profile T BUOY data should' // &  
     835                        &           ' only occur at the end of a given day' )  
     836     
     837                  ENDIF  
     838          
     839               ELSE   
     840                 
     841                  ! Point data  
     842      
     843                  ! vertically interpolate all 4 corners  
     844                  ista = prodatqc%npvsta(jobs,1)  
     845                  iend = prodatqc%npvend(jobs,1)  
     846                  inum_obs = iend - ista + 1  
     847                  ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs))  
     848                  DO iin=1,2   
     849                     DO ijn=1,2  
     850                                     
     851                                     
     852                        IF ( k1dint == 1 ) THEN  
     853                           CALL obs_int_z1d_spl( kpk, &  
     854                              &    zintt(iin,ijn,:,iobs),&  
     855                              &    zobs2k, zgdept(iin,ijn,:,iobs), &  
     856                              &    zmask(iin,ijn,:,iobs))  
     857   
     858                        ENDIF  
     859        
     860                        CALL obs_level_search(kpk, &  
     861                            &        zgdept(iin,ijn,:,iobs),&  
     862                            &        inum_obs, prodatqc%var(1)%vdep(ista:iend), &  
     863                            &         iv_indic)  
     864                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,     &  
     865                            &          prodatqc%var(1)%vdep(ista:iend),     &  
     866                            &          zintt(iin,ijn,:,iobs),            &  
     867                            &          zobs2k,interp_corner(iin,ijn,:), &  
     868                            &          zgdept(iin,ijn,:,iobs),         &  
     869                            &          zmask(iin,ijn,:,iobs) )       
     870          
     871                     ENDDO  
     872                  ENDDO  
     873              
     874               ENDIF  
     875        
     876               !-------------------------------------------------------------  
     877               ! Compute the horizontal interpolation for every profile level  
     878               !-------------------------------------------------------------  
     879              
     880               DO ikn=1,inum_obs  
     881                  iend=ista+ikn-1  
     882 
     883                  l_zweig(:,:,1) = 0._wp  
     884 
     885                  ! This code forces the horizontal weights to be   
     886                  ! zero IF the observation is below the bottom of the   
     887                  ! corners of the interpolation nodes, Or if it is in   
     888                  ! the mask. This is important for observations are near   
     889                  ! steep bathymetry  
     890                  DO iin=1,2  
     891                     DO ijn=1,2  
     892      
     893                        depth_loop1: DO ik=kpk,2,-1  
     894                           IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN    
     895                             
     896                              l_zweig(iin,ijn,1) = &   
     897                                 & zweig(iin,ijn,1) * &  
     898                                 & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) &  
     899                                 &  - prodatqc%var(1)%vdep(iend)),0._wp)  
     900                             
     901                              EXIT depth_loop1  
     902                           ENDIF  
     903                        ENDDO depth_loop1  
     904      
     905                     ENDDO  
     906                  ENDDO  
     907    
     908                  CALL obs_int_h2d( 1, 1, l_zweig, interp_corner(:,:,ikn), &  
     909                  &          prodatqc%var(1)%vmod(iend:iend) )  
     910  
     911               ENDDO  
     912  
     913  
     914               DEALLOCATE(interp_corner,iv_indic)  
     915           
     916            ENDIF  
     917        
     918  
     919            ! Salinity   
     920           
     921            IF ( prodatqc%npvend(jobs,2) > 0 ) THEN   
     922     
     923               zobsk(:) = obfillflt  
     924     
     925               IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN  
     926     
     927                  IF ( idayend == 0 )  THEN  
     928                    
     929                     ! Daily averaged moored buoy (MRB) data  
     930                    
     931                     ! vertically interpolate all 4 corners  
     932                     ista = prodatqc%npvsta(iobs,2)  
     933                     iend = prodatqc%npvend(iobs,2)  
     934                     inum_obs = iend - ista + 1  
     935                     ALLOCATE(interp_corner(2,2,inum_obs),iv_indic(inum_obs))  
     936       
     937                     DO iin=1,2  
     938                        DO ijn=1,2  
     939                                        
     940                                        
     941            
     942                           IF ( k1dint == 1 ) THEN  
     943                              CALL obs_int_z1d_spl( kpk, &  
     944                                 &     zinms(iin,ijn,:,iobs), &  
     945                                 &     zobs2k, zgdept(iin,ijn,:,iobs), &  
     946                                 &     zmask(iin,ijn,:,iobs))  
     947                           ENDIF  
     948        
     949                           CALL obs_level_search(kpk, &  
     950                              &    zgdept(iin,ijn,:,iobs), &  
     951                              &    inum_obs, prodatqc%var(2)%vdep(ista:iend), &  
     952                              &    iv_indic)  
     953                           CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, &  
     954                              &    prodatqc%var(2)%vdep(ista:iend), &  
     955                              &    zinms(iin,ijn,:,iobs), &  
     956                              &    zobs2k, interp_corner(iin,ijn,:), &  
     957                              &    zgdept(iin,ijn,:,iobs), &  
     958                              &    zmask(iin,ijn,:,iobs))  
     959        
     960                        ENDDO  
     961                     ENDDO  
     962                    
     963                    
     964                  ELSE  
     965                 
     966                     CALL ctl_stop( ' A nonzero' //     &  
     967                        &           ' number of profile T BUOY data should' // &  
     968                        &           ' only occur at the end of a given day' )  
     969     
     970                  ENDIF  
     971          
     972               ELSE   
     973                 
     974                  ! Point data  
     975      
     976                  ! vertically interpolate all 4 corners  
     977                  ista = prodatqc%npvsta(jobs,2)  
     978                  iend = prodatqc%npvend(jobs,2)  
     979                  inum_obs = iend - ista + 1  
     980                  ALLOCATE(interp_corner(2,2,inum_obs), iv_indic(inum_obs))  
     981                    
     982                  DO iin=1,2      
     983                     DO ijn=1,2   
     984                                  
     985                                  
     986                        IF ( k1dint == 1 ) THEN  
     987                           CALL obs_int_z1d_spl( kpk, &  
     988                              &    zints(iin,ijn,:,iobs),&  
     989                              &    zobs2k, zgdept(iin,ijn,:,iobs), &  
     990                              &    zmask(iin,ijn,:,iobs))  
     991   
     992                        ENDIF  
     993        
     994                        CALL obs_level_search(kpk, &  
     995                           &        zgdept(iin,ijn,:,iobs),&  
     996                           &        inum_obs, prodatqc%var(2)%vdep(ista:iend), &  
     997                           &         iv_indic)  
     998                        CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs,  &  
     999                           &          prodatqc%var(2)%vdep(ista:iend),     &  
     1000                           &          zints(iin,ijn,:,iobs),               &  
     1001                           &          zobs2k,interp_corner(iin,ijn,:),     &  
     1002                           &          zgdept(iin,ijn,:,iobs),              &  
     1003                           &          zmask(iin,ijn,:,iobs) )       
     1004          
     1005                     ENDDO  
     1006                  ENDDO  
     1007              
     1008               ENDIF  
     1009        
     1010               !-------------------------------------------------------------  
     1011               ! Compute the horizontal interpolation for every profile level  
     1012               !-------------------------------------------------------------  
     1013              
     1014               DO ikn=1,inum_obs  
     1015                  iend=ista+ikn-1  
     1016 
     1017                  l_zweig(:,:,1) = 0._wp 
     1018    
     1019                  ! This code forces the horizontal weights to be   
     1020                  ! zero IF the observation is below the bottom of the   
     1021                  ! corners of the interpolation nodes, Or if it is in   
     1022                  ! the mask. This is important for observations are near   
     1023                  ! steep bathymetry  
     1024                  DO iin=1,2  
     1025                     DO ijn=1,2  
     1026      
     1027                        depth_loop2: DO ik=kpk,2,-1  
     1028                           IF(zmask(iin,ijn,ik-1,iobs ) > 0.9 )THEN    
     1029                             
     1030                              l_zweig(iin,ijn,1) = &   
     1031                                 &  zweig(iin,ijn,1) * &  
     1032                                 &  MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) &  
     1033                                 &  - prodatqc%var(2)%vdep(iend)),0._wp)  
     1034                             
     1035                              EXIT depth_loop2  
     1036                           ENDIF  
     1037                        ENDDO depth_loop2  
     1038      
     1039                     ENDDO  
     1040                  ENDDO  
     1041    
     1042                  CALL obs_int_h2d( 1, 1, l_zweig, interp_corner(:,:,ikn), &  
     1043                  &          prodatqc%var(2)%vmod(iend:iend) )  
     1044  
     1045               ENDDO  
     1046  
     1047  
     1048               DEALLOCATE(interp_corner,iv_indic)  
     1049           
     1050            ENDIF  
     1051           
     1052         ENDIF  
     1053        
     1054      END DO  
     1055      
     1056      ! Deallocate the data for interpolation  
     1057      DEALLOCATE( &  
     1058         & igrdi, &  
     1059         & igrdj, &  
     1060         & zglam, &  
     1061         & zgphi, &  
     1062         & zmask, &  
     1063         & zintt, &  
     1064         & zints, &  
     1065         & zgdept,& 
     1066         & zgdepw & 
     1067         & )  
     1068      ! At the end of the day also get interpolated means  
     1069      IF ( idayend == 0 ) THEN  
     1070         DEALLOCATE( &  
     1071            & zinmt,  &  
     1072            & zinms   &  
     1073            & )  
     1074      ENDIF  
     1075     
     1076      prodatqc%nprofup = prodatqc%nprofup + ipro   
     1077        
     1078   END SUBROUTINE obs_pro_sco_opt  
     1079  
     1080   SUBROUTINE obs_surf_opt( surfdataqc, kt, kpi, kpj,         & 
     1081      &                    kit000, kdaystp, psurf, psurfmask, & 
     1082      &                    k2dint, ldnightav ) 
     1083 
    4531084      !!----------------------------------------------------------------------- 
    4541085      !! 
    455       !!                     ***  ROUTINE obs_sla_opt  *** 
    456       !! 
    457       !! ** Purpose : Compute the model counterpart of sea level anomaly 
     1086      !!                     ***  ROUTINE obs_surf_opt  *** 
     1087      !! 
     1088      !! ** Purpose : Compute the model counterpart of surface 
    4581089      !!              data by interpolating from the model grid to the  
    4591090      !!              observation point. 
    … …  
    4621093      !!              the model values at the corners of the surrounding grid box. 
    4631094      !! 
    464       !!    The now model SSH is first computed at the obs (lon, lat) point. 
     1095      !!    The new model value is first computed at the obs (lon, lat) point. 
    4651096      !! 
    4661097      !!    Several horizontal interpolation schemes are available: 
    … …  
    4701101      !!        - bilinear (quadrilateral grid)    (k2dint = 3) 
    4711102      !!        - 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). 
     1103      !! 
    4751104      !! 
    4761105      !! ** Action  : 
    … …  
    4781107      !! History : 
    4791108      !!      ! 07-03 (A. Weaver) 
     1109      !!      ! 15-02 (M. Martin) Combined routine for surface types 
    4801110      !!----------------------------------------------------------------------- 
    481    
     1111 
    4821112      !! * Modules used 
    4831113      USE obs_surf_def  ! Definition of storage space for surface observations 
    … …  
    4861116 
    4871117      !! * 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 
     1118      TYPE(obs_surf), INTENT(INOUT) :: & 
     1119         & surfdataqc                  ! Subset of surface data passing QC 
     1120      INTEGER, INTENT(IN) :: kt        ! Time step 
     1121      INTEGER, INTENT(IN) :: kpi       ! Model grid parameters 
    4911122      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           
     1123      INTEGER, INTENT(IN) :: kit000    ! Number of the first time step  
     1124                                       !   (kit000-1 = restart time) 
     1125      INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day 
     1126      INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
     1127      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
     1128         & psurf,  &                   ! Model surface field 
     1129         & psurfmask                   ! Land-sea mask 
     1130      LOGICAL, INTENT(IN) :: ldnightav ! Logical for averaging night-time data 
     1131 
    4991132      !! * Local declarations 
    5001133      INTEGER :: ji 
    … …  
    5021135      INTEGER :: jobs 
    5031136      INTEGER :: inrc 
    504       INTEGER :: isla 
     1137      INTEGER :: isurf 
    5051138      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 
    511       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    512          & zmask, & 
    513          & zsshl, & 
    514          & zglam, & 
    515          & zgphi 
     1139      INTEGER :: idayend 
    5161140      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    5171141         & igrdi, & 
    5181142         & igrdj 
     1143      INTEGER, DIMENSION(:,:), SAVE, ALLOCATABLE :: & 
     1144         & icount_night,      & 
     1145         & imask_night 
     1146      REAL(wp) :: zlam 
     1147      REAL(wp) :: zphi 
     1148      REAL(wp), DIMENSION(1) :: zext, zobsmask 
     1149      REAL(wp) :: zdaystp 
     1150      REAL(wp), DIMENSION(2,2,1) :: & 
     1151         & zweig 
     1152      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
     1153         & zmask,  & 
     1154         & zsurf,  & 
     1155         & zsurfm, & 
     1156         & zglam,  & 
     1157         & zgphi 
     1158      REAL(wp), DIMENSION(:,:), SAVE, ALLOCATABLE :: & 
     1159         & zintmp,  & 
     1160         & zouttmp, & 
     1161         & zmeanday    ! to compute model sst in region of 24h daylight (pole) 
    5191162 
    5201163      !------------------------------------------------------------------------ 
    5211164      ! Local initialization  
    5221165      !------------------------------------------------------------------------ 
    523       ! ... Record and data counters 
     1166      ! Record and data counters 
    5241167      inrc = kt - kit000 + 2 
    525       isla = sladatqc%nsstp(inrc) 
     1168      isurf = surfdataqc%nsstp(inrc) 
     1169 
     1170      IF ( ldnightav ) THEN 
     1171 
     1172      ! Initialize array for night mean 
     1173         IF ( kt == 0 ) THEN 
     1174            ALLOCATE ( icount_night(kpi,kpj) ) 
     1175            ALLOCATE ( imask_night(kpi,kpj) ) 
     1176            ALLOCATE ( zintmp(kpi,kpj) ) 
     1177            ALLOCATE ( zouttmp(kpi,kpj) ) 
     1178            ALLOCATE ( zmeanday(kpi,kpj) ) 
     1179            nday_qsr = -1   ! initialisation flag for nbc_dcy 
     1180         ENDIF 
     1181 
     1182         ! Night-time means are calculated for night-time values over timesteps: 
     1183         !  [1 <= kt <= kdaystp], [kdaystp+1 <= kt <= 2*kdaystp], ..... 
     1184         idayend = MOD( kt - kit000 + 1, kdaystp ) 
     1185 
     1186         ! Initialize night-time mean for first timestep of the day 
     1187         IF ( idayend == 1 .OR. kt == 0 ) THEN 
     1188            DO jj = 1, jpj 
     1189               DO ji = 1, jpi 
     1190                  surfdataqc%vdmean(ji,jj) = 0.0 
     1191                  zmeanday(ji,jj) = 0.0 
     1192                  icount_night(ji,jj) = 0 
     1193               END DO 
     1194            END DO 
     1195         ENDIF 
     1196 
     1197         zintmp(:,:) = 0.0 
     1198         zouttmp(:,:) = sbc_dcy( zintmp(:,:), .TRUE. ) 
     1199         imask_night(:,:) = INT( zouttmp(:,:) ) 
     1200 
     1201         DO jj = 1, jpj 
     1202            DO ji = 1, jpi 
     1203               ! Increment the temperature field for computing night mean and counter 
     1204               surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj)  & 
     1205                      &                    + psurf(ji,jj) * REAL( imask_night(ji,jj) ) 
     1206               zmeanday(ji,jj)          = zmeanday(ji,jj) + psurf(ji,jj) 
     1207               icount_night(ji,jj)      = icount_night(ji,jj) + imask_night(ji,jj) 
     1208            END DO 
     1209         END DO 
     1210 
     1211         ! Compute the night-time mean at the end of the day 
     1212         zdaystp = 1.0 / REAL( kdaystp ) 
     1213         IF ( idayend == 0 ) THEN 
     1214            IF (lwp) WRITE(numout,*) 'Calculating surfdataqc%vdmean on time-step: ',kt 
     1215            DO jj = 1, jpj 
     1216               DO ji = 1, jpi 
     1217                  ! Test if "no night" point 
     1218                  IF ( icount_night(ji,jj) > 0 ) THEN 
     1219                     surfdataqc%vdmean(ji,jj) = surfdataqc%vdmean(ji,jj) & 
     1220                       &                        / REAL( icount_night(ji,jj) ) 
     1221                  ELSE 
     1222                     !At locations where there is no night (e.g. poles), 
     1223                     ! calculate daily mean instead of night-time mean. 
     1224                     surfdataqc%vdmean(ji,jj) = zmeanday(ji,jj) * zdaystp 
     1225                  ENDIF 
     1226               END DO 
     1227            END DO 
     1228         ENDIF 
     1229 
     1230      ENDIF 
    5261231 
    5271232      ! Get the data for interpolation 
    5281233 
    5291234      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)  & 
     1235         & igrdi(2,2,isurf), & 
     1236         & igrdj(2,2,isurf), & 
     1237         & zglam(2,2,isurf), & 
     1238         & zgphi(2,2,isurf), & 
     1239         & zmask(2,2,isurf), & 
     1240         & zsurf(2,2,isurf)  & 
    5361241         & ) 
    537        
    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) 
     1242 
     1243      DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 
     1244         iobs = jobs - surfdataqc%nsurfup 
     1245         igrdi(1,1,iobs) = surfdataqc%mi(jobs)-1 
     1246         igrdj(1,1,iobs) = surfdataqc%mj(jobs)-1 
     1247         igrdi(1,2,iobs) = surfdataqc%mi(jobs)-1 
     1248         igrdj(1,2,iobs) = surfdataqc%mj(jobs) 
     1249         igrdi(2,1,iobs) = surfdataqc%mi(jobs) 
     1250         igrdj(2,1,iobs) = surfdataqc%mj(jobs)-1 
     1251         igrdi(2,2,iobs) = surfdataqc%mi(jobs) 
     1252         igrdj(2,2,iobs) = surfdataqc%mj(jobs) 
    5481253      END DO 
    5491254 
    550       CALL obs_int_comm_2d( 2, 2, isla, & 
     1255      CALL obs_int_comm_2d( 2, 2, isurf, kpi, kpj, & 
    5511256         &                  igrdi, igrdj, glamt, zglam ) 
    552       CALL obs_int_comm_2d( 2, 2, isla, & 
     1257      CALL obs_int_comm_2d( 2, 2, isurf, kpi, kpj, & 
    5531258         &                  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 ) 
     1259      CALL obs_int_comm_2d( 2, 2, isurf, kpi, kpj, & 
     1260         &                  igrdi, igrdj, psurfmask, zmask ) 
     1261      CALL obs_int_comm_2d( 2, 2, isurf, kpi, kpj, & 
     1262         &                  igrdi, igrdj, psurf, zsurf ) 
     1263 
     1264      ! At the end of the day get interpolated means 
     1265      IF ( idayend == 0 .AND. ldnightav ) THEN 
     1266 
     1267         ALLOCATE( & 
     1268            & zsurfm(2,2,isurf)  & 
     1269            & ) 
     1270 
     1271         CALL obs_int_comm_2d( 2, 2, isurf, kpi, kpj, igrdi, igrdj, & 
     1272            &               surfdataqc%vdmean(:,:), zsurfm ) 
     1273 
     1274      ENDIF 
    5581275 
    5591276      ! 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              
     1277      DO jobs = surfdataqc%nsurfup + 1, surfdataqc%nsurfup + isurf 
     1278 
     1279         iobs = jobs - surfdataqc%nsurfup 
     1280 
     1281         IF ( kt /= surfdataqc%mstp(jobs) ) THEN 
     1282 
    5671283            IF(lwp) THEN 
    5681284               WRITE(numout,*) 
    … …  
    5741290               WRITE(numout,*) ' Record  = ', jobs,                & 
    5751291                  &            ' kt      = ', kt,                  & 
    576                   &            ' mstp    = ', sladatqc%mstp(jobs), & 
    577                   &            ' ntyp    = ', sladatqc%ntyp(jobs) 
     1292                  &            ' mstp    = ', surfdataqc%mstp(jobs), & 
     1293                  &            ' ntyp    = ', surfdataqc%ntyp(jobs) 
    5781294            ENDIF 
    579             CALL ctl_stop( 'obs_sla_opt', 'Inconsistent time' ) 
    580              
     1295            CALL ctl_stop( 'obs_surf_opt', 'Inconsistent time' ) 
     1296 
    5811297         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 
     1298 
     1299         zlam = surfdataqc%rlam(jobs) 
     1300         zphi = surfdataqc%rphi(jobs) 
     1301 
     1302         ! Get weights to interpolate the model value to the observation point 
    5871303         CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         & 
    5881304            &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
    5891305            &                   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) 
     1306 
     1307         ! Interpolate the model field to the observation point 
     1308         IF ( ldnightav .AND. idayend == 0 ) THEN 
     1309            ! Night-time averaged data 
     1310            CALL obs_int_h2d( 1, 1, zweig, zsurfm(:,:,iobs), zext ) 
     1311         ELSE 
     1312            CALL obs_int_h2d( 1, 1, zweig, zsurf(:,:,iobs),  zext ) 
     1313         ENDIF 
     1314 
     1315         IF ( TRIM(surfdataqc%cvars(1)) == 'SLA' .AND. surfdataqc%nextra == 2 ) THEN 
     1316            ! ... Remove the MDT from the SSH at the observation point to get the SLA 
     1317            surfdataqc%rext(jobs,1) = zext(1) 
     1318            surfdataqc%rmod(jobs,1) = surfdataqc%rext(jobs,1) - surfdataqc%rext(jobs,2) 
     1319         ELSE 
     1320            surfdataqc%rmod(jobs,1) = zext(1) 
     1321         ENDIF 
    5991322 
    6001323      END DO 
    … …  
    6071330         & zgphi, & 
    6081331         & zmask, & 
    609          & zsshl  & 
     1332         & zsurf  & 
    6101333         & ) 
    6111334 
    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)  & 
    804             & ) 
    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 
     1335      ! At the end of the day also deallocate night-time mean array 
     1336      IF ( idayend == 0 .AND. ldnightav ) THEN 
    8791337         DEALLOCATE( & 
    880             & zsstm  & 
     1338            & zsurfm  & 
    8811339            & ) 
    8821340      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 
     1341 
     1342      surfdataqc%nsurfup = surfdataqc%nsurfup + isurf 
     1343 
     1344   END SUBROUTINE obs_surf_opt 
    14401345 
    14411346END MODULE obs_oper 
    1442  

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90

    r4292 r6069  
    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 
    … …  
    3633 
    3734   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   
     35      & obs_pre_prof, &    ! First level check and screening of profile obs 
     36      & obs_pre_surf, &    ! First level check and screening of surface obs 
     37      & calc_month_len     ! Calculate the number of days in the months of a year 
    4438 
    4539   !!---------------------------------------------------------------------- 
    … …  
    4943   !!---------------------------------------------------------------------- 
    5044 
     45!! * Substitutions 
     46#  include "domzgr_substitute.h90"   
     47 
    5148CONTAINS 
    5249 
    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 ) 
     50   SUBROUTINE obs_pre_surf( surfdata, surfdataqc, ld_nea ) 
    34051      !!---------------------------------------------------------------------- 
    34152      !!                    ***  ROUTINE obs_pre_sla  *** 
    34253      !! 
    343       !! ** Purpose : First level check and screening of SLA observations 
    344       !! 
    345       !! ** Method  : First level check and screening of SLA observations 
     54      !! ** Purpose : First level check and screening of surface observations 
     55      !! 
     56      !! ** Method  : First level check and screening of surface observations 
    34657      !! 
    34758      !! ** Action  :  
    … …  
    35263      !!        !  2007-03  (A. Weaver, K. Mogensen) Original 
    35364      !!        !  2007-06  (K. Mogensen et al) Reject obs. near land. 
     65      !!        !  2015-02  (M. Martin) Combined routine for surface types. 
    35466      !!---------------------------------------------------------------------- 
    35567      !! * Modules used 
    … …  
    36274         & nproc 
    36375      !! * 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 
     76      TYPE(obs_surf), INTENT(INOUT) :: surfdata    ! Full set of surface data 
     77      TYPE(obs_surf), INTENT(INOUT) :: surfdataqc   ! Subset of surface data not failing screening 
    36778      LOGICAL, INTENT(IN) :: ld_nea         ! Switch for rejecting observation near land 
    36879      !! * Local declarations 
    … …  
    391102      INTEGER :: inrc         ! Time index variable 
    392103 
    393       IF(lwp) WRITE(numout,*)'obs_pre_sla : Preparing the SLA observations...' 
    394  
     104      IF(lwp) WRITE(numout,*)'obs_pre_surf : Preparing the surface observations...' 
     105      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     106       
    395107      ! Initial date initialization (year, month, day, hour, minute) 
    396108      iyea0 =   ndate0 / 10000 
    397109      imon0 = ( ndate0 - iyea0 * 10000 ) / 100 
    398110      iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100 
    399       ihou0 = 0 
    400       imin0 = 0 
     111      ihou0 = nn_time0 / 100 
     112      imin0 = ( nn_time0 - ihou0 * 100 ) 
    401113 
    402114      icycle = no     ! Assimilation cycle 
    … …  
    411123 
    412124      ! ----------------------------------------------------------------------- 
    413       ! Find time coordinate for SLA data 
     125      ! Find time coordinate for surface data 
    414126      ! ----------------------------------------------------------------------- 
    415127 
    416128      CALL obs_coo_tim( icycle, & 
    417129         &              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        ) 
     130         &              surfdata%nsurf,   surfdata%nyea, surfdata%nmon, & 
     131         &              surfdata%nday,    surfdata%nhou, surfdata%nmin, & 
     132         &              surfdata%nqc,     surfdata%mstp, iotdobs        ) 
    421133 
    422134      CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    423135       
    424136      ! ----------------------------------------------------------------------- 
    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                         ) 
     137      ! Check for surface data failing the grid search 
     138      ! ----------------------------------------------------------------------- 
     139 
     140      CALL obs_coo_grd( surfdata%nsurf,   surfdata%mi, surfdata%mj, & 
     141         &              surfdata%nqc,     igrdobs                         ) 
    430142 
    431143      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    … …  
    435147      ! ----------------------------------------------------------------------- 
    436148 
    437       CALL obs_coo_spc_2d( sladata%nsurf,              & 
     149      CALL obs_coo_spc_2d( surfdata%nsurf,              & 
    438150         &                 jpi,          jpj,          & 
    439          &                 sladata%mi,   sladata%mj,   &  
    440          &                 sladata%rlam, sladata%rphi, & 
     151         &                 surfdata%mi,   surfdata%mj,   &  
     152         &                 surfdata%rlam, surfdata%rphi, & 
    441153         &                 glamt,        gphit,        & 
    442          &                 tmask(:,:,1), sladata%nqc,  & 
     154         &                 tmask(:,:,1), surfdata%nqc,  & 
    443155         &                 iosdsobs,     ilansobs,     & 
    444156         &                 inlasobs,     ld_nea        ) 
    … …  
    449161 
    450162      ! ----------------------------------------------------------------------- 
    451       ! Copy useful data from the sladata data structure to 
    452       ! the sladatqc data structure  
     163      ! Copy useful data from the surfdata data structure to 
     164      ! the surfdataqc data structure  
    453165      ! ----------------------------------------------------------------------- 
    454166 
    455167      ! Allocate the selection arrays 
    456168 
    457       ALLOCATE( llvalid(sladata%nsurf) ) 
     169      ALLOCATE( llvalid(surfdata%nsurf) ) 
    458170       
    459171      ! We want all data which has qc flags <= 10 
    460172 
    461       llvalid(:)  = ( sladata%nqc(:)  <= 10 ) 
     173      llvalid(:)  = ( surfdata%nqc(:)  <= 10 ) 
    462174 
    463175      ! The actual copying 
    464176 
    465       CALL obs_surf_compress( sladata,     sladatqc,       .TRUE.,  numout, & 
     177      CALL obs_surf_compress( surfdata,     surfdataqc,       .TRUE.,  numout, & 
    466178         &                    lvalid=llvalid ) 
    467179 
    … …  
    477189      IF(lwp) THEN 
    478190         WRITE(numout,*) 
    479          WRITE(numout,*) 'obs_pre_sla :' 
    480          WRITE(numout,*) '~~~~~~~~~~~' 
    481          WRITE(numout,*) 
    482          WRITE(numout,*) ' SLA data outside time domain                  = ', & 
     191         WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data outside time domain                  = ', & 
    483192            &            iotdobsmpp 
    484          WRITE(numout,*) ' Remaining SLA data that failed grid search    = ', & 
     193         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data that failed grid search    = ', & 
    485194            &            igrdobsmpp 
    486          WRITE(numout,*) ' Remaining SLA data outside space domain       = ', & 
     195         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data outside space domain       = ', & 
    487196            &            iosdsobsmpp 
    488          WRITE(numout,*) ' Remaining SLA data at land points             = ', & 
     197         WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data at land points             = ', & 
    489198            &            ilansobsmpp 
    490199         IF (ld_nea) THEN 
    491             WRITE(numout,*) ' Remaining SLA data near land points (removed) = ', & 
     200            WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (removed) = ', & 
    492201               &            inlasobsmpp 
    493202         ELSE 
    494             WRITE(numout,*) ' Remaining SLA data near land points (kept)    = ', & 
     203            WRITE(numout,*) ' Remaining '//surfdataqc%cvars(1)//' data near land points (kept)    = ', & 
    495204               &            inlasobsmpp 
    496205         ENDIF 
    497          WRITE(numout,*) ' SLA data accepted                             = ', & 
    498             &            sladatqc%nsurfmpp 
     206         WRITE(numout,*) ' '//surfdataqc%cvars(1)//' data accepted                             = ', & 
     207            &            surfdataqc%nsurfmpp 
    499208 
    500209         WRITE(numout,*) 
    501210         WRITE(numout,*) ' Number of observations per time step :' 
    502211         WRITE(numout,*) 
    503          WRITE(numout,1997) 
    504          WRITE(numout,1998) 
     212         WRITE(numout,'(10X,A,10X,A)')'Time step',surfdataqc%cvars(1) 
     213         WRITE(numout,'(10X,A,5X,A)')'---------','-----------------' 
     214         CALL FLUSH(numout) 
    505215      ENDIF 
    506216       
    507       DO jobs = 1, sladatqc%nsurf 
    508          inrc = sladatqc%mstp(jobs) + 2 - nit000 
    509          sladatqc%nsstp(inrc)  = sladatqc%nsstp(inrc) + 1 
     217      DO jobs = 1, surfdataqc%nsurf 
     218         inrc = surfdataqc%mstp(jobs) + 2 - nit000 
     219         surfdataqc%nsstp(inrc)  = surfdataqc%nsstp(inrc) + 1 
    510220      END DO 
    511221       
    512       CALL obs_mpp_sum_integers( sladatqc%nsstp, sladatqc%nsstpmpp, & 
     222      CALL obs_mpp_sum_integers( surfdataqc%nsstp, surfdataqc%nsstpmpp, & 
    513223         &                       nitend - nit000 + 2 ) 
    514224 
    … …  
    516226         DO jstp = nit000 - 1, nitend 
    517227            inrc = jstp - nit000 + 2 
    518             WRITE(numout,1999) jstp, sladatqc%nsstpmpp(inrc) 
     228            WRITE(numout,1999) jstp, surfdataqc%nsstpmpp(inrc) 
     229            CALL FLUSH(numout) 
    519230         END DO 
    520231      ENDIF 
    521232 
    522 1997  FORMAT(10X,'Time step',5X,'Sea level anomaly') 
    523 1998  FORMAT(10X,'---------',5X,'-----------------') 
    5242331999  FORMAT(10X,I9,5X,I17) 
    525234 
    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       !!    
     235   END SUBROUTINE obs_pre_surf 
     236 
     237 
     238   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, & 
     239      &                     kpi, kpj, kpk, & 
     240      &                     zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2,  & 
     241      &                     ld_nea, kdailyavtypes ) 
     242 
     243!!---------------------------------------------------------------------- 
     244      !!                    ***  ROUTINE obs_pre_prof  *** 
     245      !! 
     246      !! ** Purpose : First level check and screening of profiles 
     247      !! 
     248      !! ** Method  : First level check and screening of profiles 
     249      !! 
    540250      !! History : 
    541       !!        !  2007-03  (S. Ricci) SST data preparation  
     251      !!        !  2007-06  (K. Mogensen) original : T and S profile data 
     252      !!        !  2008-09  (M. Valdivieso) : TAO velocity data 
     253      !!        !  2009-01  (K. Mogensen) : New feedback stricture 
     254      !!        !  2015-02  (M. Martin) : Combined profile routine. 
     255      !! 
    542256      !!---------------------------------------------------------------------- 
    543257      !! * Modules used 
    … …  
    545259      USE par_oce             ! Ocean parameters 
    546260      USE dom_oce, ONLY : &   ! Geographical information 
    547          & glamt,   & 
    548          & gphit,   & 
    549          & tmask,   & 
     261         & gdept_1d,             & 
    550262         & nproc 
    551       !! * 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 
    556       !! * Local declarations 
    557       INTEGER :: iyea0        ! Initial date 
    558       INTEGER :: imon0        !  - (year, month, day, hour, minute) 
    559       INTEGER :: iday0    
    560       INTEGER :: ihou0     
    561       INTEGER :: imin0 
    562       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 
    577       INTEGER :: jobs         ! Obs. loop variable 
    578       INTEGER :: jstp         ! Time loop variable 
    579       INTEGER :: inrc         ! Time index variable 
    580  
    581       IF(lwp) WRITE(numout,*)'obs_pre_sst : Preparing the SST observations...' 
    582  
    583       ! Initial date initialization (year, month, day, hour, minute) 
    584       iyea0 =   ndate0 / 10000 
    585       imon0 = ( ndate0 - iyea0 * 10000 ) / 100 
    586       iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100 
    587       ihou0 = 0 
    588       imin0 = 0 
    589  
    590       icycle = no     ! Assimilation cycle 
    591  
    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        ) 
    609       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                         ) 
    616       CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    617  
    618       ! ----------------------------------------------------------------------- 
    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 
     263 
    921264      !! * Arguments 
    922265      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    923266      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 
     267      LOGICAL, INTENT(IN) :: ld_var1              ! Observed variables switches 
     268      LOGICAL, INTENT(IN) :: ld_var2 
     269      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land 
     270      INTEGER, INTENT(IN) :: kpi, kpj, kpk        ! Local domain sizes 
     271      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
     272         & kdailyavtypes                          ! Types for daily averages 
     273      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
     274         & zmask1, & 
     275         & zmask2 
     276      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
     277         & pglam1, & 
     278         & pglam2, & 
     279         & pgphi1, & 
     280         & pgphi2 
     281 
    927282      !! * Local declarations 
    928283      INTEGER :: iyea0        ! Initial date 
    … …  
    932287      INTEGER :: imin0 
    933288      INTEGER :: icycle       ! Current assimilation cycle 
    934                               ! Counters for observations that 
     289                              ! Counters for observations that are 
    935290      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) 
     291      INTEGER :: iosdv1obs    !  - outside space domain (variable 1) 
     292      INTEGER :: iosdv2obs    !  - outside space domain (variable 2) 
     293      INTEGER :: ilanv1obs    !  - within a model land cell (variable 1) 
     294      INTEGER :: ilanv2obs    !  - within a model land cell (variable 2) 
     295      INTEGER :: inlav1obs    !  - close to land (variable 1) 
     296      INTEGER :: inlav2obs    !  - close to land (variable 2) 
    942297      INTEGER :: igrdobs      !  - fail the grid search 
    943298      INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    944299      INTEGER :: iuvchkv      ! 
    945                               ! Global counters for observations that 
     300                              ! Global counters for observations that are 
    946301      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) 
     302      INTEGER :: iosdv1obsmpp !  - outside space domain (variable 1) 
     303      INTEGER :: iosdv2obsmpp !  - outside space domain (variable 2) 
     304      INTEGER :: ilanv1obsmpp !  - within a model land cell (variable 1) 
     305      INTEGER :: ilanv2obsmpp !  - within a model land cell (variable 2) 
     306      INTEGER :: inlav1obsmpp !  - close to land (variable 1) 
     307      INTEGER :: inlav2obsmpp !  - close to land (variable 2) 
    953308      INTEGER :: igrdobsmpp   !  - fail the grid search 
    954       INTEGER :: iuvchkumpp   !  - reject u if v rejected and vice versa 
     309      INTEGER :: iuvchkumpp   !  - reject var1 if var2 rejected and vice versa 
    955310      INTEGER :: iuvchkvmpp   ! 
    956311      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
    957312      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    958          & llvvalid           ! U,V selection  
     313         & llvvalid           ! var1,var2 selection  
    959314      INTEGER :: jvar         ! Variable loop variable 
    960315      INTEGER :: jobs         ! Obs. loop variable 
    … …  
    962317      INTEGER :: inrc         ! Time index variable 
    963318 
    964       IF(lwp) WRITE(numout,*)'obs_pre_vel: Preparing the velocity profile data' 
     319      IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' 
     320      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    965321 
    966322      ! Initial date initialization (year, month, day, hour, minute) 
    … …  
    968324      imon0 = ( ndate0 - iyea0 * 10000 ) / 100 
    969325      iday0 =   ndate0 - iyea0 * 10000 - imon0 * 100 
    970       ihou0 = 0 
    971       imin0 = 0 
     326      ihou0 = nn_time0 / 100 
     327      imin0 = ( nn_time0 - ihou0 * 100 ) 
    972328 
    973329      icycle = no     ! Assimilation cycle 
    … …  
    977333      iotdobs  = 0 
    978334      igrdobs  = 0 
    979       iosduobs = 0 
    980       iosdvobs = 0 
    981       ilanuobs = 0 
    982       ilanvobs = 0 
    983       inlauobs = 0 
    984       inlavobs = 0 
     335      iosdv1obs = 0 
     336      iosdv2obs = 0 
     337      ilanv1obs = 0 
     338      ilanv2obs = 0 
     339      inlav1obs = 0 
     340      inlav2obs = 0 
    985341      iuvchku  = 0 
    986342      iuvchkv = 0 
    … …  
    990346      ! ----------------------------------------------------------------------- 
    991347 
    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      
     348      IF ( PRESENT(kdailyavtypes) ) THEN 
     349         CALL obs_coo_tim_prof( icycle, & 
     350            &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
     351            &              profdata%nprof,   profdata%nyea, profdata%nmon, & 
     352            &              profdata%nday,    profdata%nhou, profdata%nmin, & 
     353            &              profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
     354            &              iotdobs, kdailyavtypes = kdailyavtypes ) 
     355      ELSE 
     356         CALL obs_coo_tim_prof( icycle, & 
     357            &              iyea0,   imon0,   iday0,   ihou0,   imin0,      & 
     358            &              profdata%nprof,   profdata%nyea, profdata%nmon, & 
     359            &              profdata%nday,    profdata%nhou, profdata%nmin, & 
     360            &              profdata%ntyp,    profdata%nqc,  profdata%mstp, & 
     361            &              iotdobs ) 
     362      ENDIF 
     363 
    999364      CALL obs_mpp_sum_integer( iotdobs, iotdobsmpp ) 
    1000365       
    … …  
    1021386      ! ----------------------------------------------------------------------- 
    1022387 
    1023       ! Zonal Velocity Component 
    1024  
     388      ! Variable 1 
    1025389      CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    1026390         &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    1027391         &                 jpi,                   jpj,                  & 
    1028392         &                 jpk,                                         & 
    1029          &                 profdata%mi,           profdata%mj,          &  
     393         &                 profdata%mi,           profdata%mj,          & 
    1030394         &                 profdata%var(1)%mvk,                         & 
    1031395         &                 profdata%rlam,         profdata%rphi,        & 
    1032396         &                 profdata%var(1)%vdep,                        & 
    1033          &                 glamu,                 gphiu,                & 
    1034          &                 gdept_1d,              umask,                & 
     397         &                 pglam1,                pgphi1,               & 
     398         &                 gdept_1d,              zmask1,               & 
    1035399         &                 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  
     400         &                 iosdv1obs,              ilanv1obs,           & 
     401         &                 inlav1obs,              ld_nea                ) 
     402 
     403      CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 
     404      CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 
     405      CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 
     406 
     407      ! Variable 2 
    1045408      CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    1046409         &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    … …  
    1051414         &                 profdata%rlam,         profdata%rphi,        & 
    1052415         &                 profdata%var(2)%vdep,                        & 
    1053          &                 glamv,                 gphiv,                & 
    1054          &                 gdept_1d,              vmask,                & 
     416         &                 pglam2,                pgphi2,               & 
     417         &                 gdept_1d,              zmask2,               & 
    1055418         &                 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 ) 
     419         &                 iosdv2obs,              ilanv2obs,           & 
     420         &                 inlav2obs,              ld_nea                ) 
     421 
     422      CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 
     423      CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 
     424      CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 
    1062425 
    1063426      ! ----------------------------------------------------------------------- 
    … …  
    1065428      ! ----------------------------------------------------------------------- 
    1066429 
    1067       CALL obs_uv_rej( profdata, iuvchku, iuvchkv ) 
    1068       CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 
    1069       CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 
     430      IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
     431         CALL obs_uv_rej( profdata, iuvchku, iuvchkv ) 
     432         CALL obs_mpp_sum_integer( iuvchku, iuvchkumpp ) 
     433         CALL obs_mpp_sum_integer( iuvchkv, iuvchkvmpp ) 
     434      ENDIF 
    1070435 
    1071436      ! ----------------------------------------------------------------------- 
    … …  
    1106471       
    1107472      IF(lwp) THEN 
     473       
    1108474         WRITE(numout,*) 
    1109          WRITE(numout,*) 'obs_pre_vel :' 
    1110          WRITE(numout,*) '~~~~~~~~~~~' 
    1111          WRITE(numout,*) 
    1112          WRITE(numout,*) ' Profiles outside time domain                = ', & 
     475         WRITE(numout,*) ' Profiles outside time domain                     = ', & 
    1113476            &            iotdobsmpp 
    1114          WRITE(numout,*) ' Remaining profiles that failed grid search  = ', & 
     477         WRITE(numout,*) ' Remaining profiles that failed grid search       = ', & 
    1115478            &            igrdobsmpp 
    1116          WRITE(numout,*) ' Remaining U data outside space domain       = ', & 
    1117             &            iosduobsmpp 
    1118          WRITE(numout,*) ' Remaining U data at land points             = ', & 
    1119             &            ilanuobsmpp 
     479         WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain       = ', & 
     480            &            iosdv1obsmpp 
     481         WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points             = ', & 
     482            &            ilanv1obsmpp 
    1120483         IF (ld_nea) THEN 
    1121             WRITE(numout,*) ' Remaining U data near land points (removed) = ',& 
    1122                &            inlauobsmpp 
     484            WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 
     485               &            inlav1obsmpp 
    1123486         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                             = ', & 
     487            WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept)    = ',& 
     488               &            inlav1obsmpp 
     489         ENDIF 
     490         IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
     491            WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
     492               &            iuvchku 
     493         ENDIF 
     494         WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted                             = ', & 
    1130495            &            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 
     496         WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain       = ', & 
     497            &            iosdv2obsmpp 
     498         WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points             = ', & 
     499            &            ilanv2obsmpp 
    1135500         IF (ld_nea) THEN 
    1136             WRITE(numout,*) ' Remaining V data near land points (removed) = ',& 
    1137                &            inlavobsmpp 
     501            WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 
     502               &            inlav2obsmpp 
    1138503         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                             = ', & 
     504            WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept)    = ',& 
     505               &            inlav2obsmpp 
     506         ENDIF 
     507         IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
     508            WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
     509               &            iuvchkv 
     510         ENDIF 
     511         WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted                             = ', & 
    1145512            &            prodatqc%nvprotmpp(2) 
    1146513 
    … …  
    1148515         WRITE(numout,*) ' Number of observations per time step :' 
    1149516         WRITE(numout,*) 
    1150          WRITE(numout,997) 
     517         WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 
     518            &                               '     '//prodatqc%cvars(1)//'     ', & 
     519            &                               '     '//prodatqc%cvars(2)//'     ' 
    1151520         WRITE(numout,998) 
    1152521      ENDIF 
    … …  
    1182551      ENDIF 
    1183552 
    1184 997   FORMAT(10X,'Time step',5X,'Profiles',5X,'Zonal Comp.',5X,'Meridional Comp.') 
    1185553998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 
    1186554999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    1187555 
    1188    END SUBROUTINE obs_pre_vel 
     556   END SUBROUTINE obs_pre_prof 
    1189557 
    1190558   SUBROUTINE obs_coo_tim( kcycle, & 
    … …  
    1388756      &                    kobsno,                                        & 
    1389757      &                    kobsyea, kobsmon, kobsday, kobshou, kobsmin,   & 
    1390       &                    ktyp,    kobsqc,  kobsstp, kotdobs, kdailyavtypes, & 
    1391       &                    ld_dailyav ) 
     758      &                    ktyp,    kobsqc,  kobsstp, kotdobs, kdailyavtypes ) 
    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 
    1436802      !! * Local declarations 
    1437803      INTEGER :: jobs 
    … …  
    1467833      ENDIF 
    1468834 
    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 
    1489835 
    1490836   END SUBROUTINE obs_coo_tim_prof 
    … …  
    1614960      END DO 
    1615961       
    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 ) 
     962      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pmask, zgmsk ) 
     963      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, plam, zglam ) 
     964      CALL obs_int_comm_2d( 2, 2, kobsno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 
    1619965 
    1620966      DO jobs = 1, kobsno 
    … …  
    17091055      !! * Modules used 
    17101056      USE dom_oce, ONLY : &       ! Geographical information 
    1711          & gdepw_1d                         
     1057         & gdepw_1d,      & 
     1058         & gdepw_0,       &                        
     1059#if defined key_vvl 
     1060         & gdepw_n,       & 
     1061         & gdept_n,       & 
     1062#endif 
     1063         & ln_zco,        & 
     1064         & ln_zps              
    17121065 
    17131066      !! * Arguments 
    … …  
    17471100      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 
    17481101         & zgmsk              ! Grid mask 
     1102      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 
     1103         & zgdepw 
    17491104      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 
    17501105         & zglam, &           ! Model longitude at grid points 
    … …  
    17541109         & igrdj 
    17551110      LOGICAL :: lgridobs           ! Is observation on a model grid point. 
     1111      LOGICAL :: ll_next_to_land    ! Is a profile next to land  
    17561112      INTEGER :: iig, ijg           ! i,j of observation on model grid point. 
    17571113      INTEGER :: jobs, jobsp, jk, ji, jj 
    … …  
    17891145      END DO 
    17901146       
    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 ) 
     1147      CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, pmask, zgmsk ) 
     1148      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, plam, zglam ) 
     1149      CALL obs_int_comm_2d( 2, 2, kprofno, kpi, kpj, igrdi, igrdj, pphi, zgphi ) 
     1150      IF ( .NOT.( ln_zps .OR. ln_zco ) ) THEN 
     1151        ! Need to know the bathy depth for each observation for sco 
     1152        CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, fsdepw(:,:,:), & 
     1153        &                     zgdepw ) 
     1154      ENDIF 
    17941155 
    17951156      DO jobs = 1, kprofno 
    … …  
    18161177         END DO 
    18171178 
     1179         ! Check if next to land 
     1180         IF (  ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN 
     1181            ll_next_to_land=.TRUE. 
     1182         ELSE 
     1183            ll_next_to_land=.FALSE. 
     1184         ENDIF  
     1185 
    18181186         ! Reject observations 
    18191187 
    … …  
    18321200            ENDIF 
    18331201 
    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 
     1202            ! To check if an observations falls within land there are two cases: 
     1203            ! 1: z-coordibnates, where the check uses the mask 
     1204            ! 2: terrain following (eg s-coordinates),  
     1205            !    where we use the depth of the bottom cell to mask observations 
     1206              
     1207            IF( ln_zps .OR. ln_zco ) THEN !(CASE 1) 
     1208                
     1209               ! Flag if the observation falls with a model land cell 
     1210               IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 
     1211                  &  == 0.0_wp ) THEN 
     1212                  kobsqc(jobsp) = kobsqc(jobsp) + 12 
     1213                  klanobs = klanobs + 1 
     1214                  CYCLE 
     1215               ENDIF 
     1216              
     1217               ! Flag if the observation is close to land 
     1218              IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 
     1219                  &  0.0_wp) THEN 
     1220                  knlaobs = knlaobs + 1 
     1221                  IF (ld_nea) THEN    
     1222                     kobsqc(jobsp) = kobsqc(jobsp) + 14  
     1223                  ENDIF  
     1224               ENDIF 
     1225              
     1226            ELSE ! Case 2 
     1227  
     1228               ! Flag if the observation is deeper than the bathymetry 
     1229               ! Or if it is within the mask 
     1230               IF ( ALL( zgdepw(1:2,1:2,kpk,jobs) < pobsdep(jobsp) ) & 
     1231                  &     .OR. & 
     1232                  &  ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 
     1233                  &  == 0.0_wp) ) THEN 
     1234                  kobsqc(jobsp) = kobsqc(jobsp) + 12 
     1235                  klanobs = klanobs + 1 
     1236                  CYCLE 
     1237               ENDIF 
     1238                
     1239               ! Flag if the observation is close to land 
     1240               IF ( ll_next_to_land ) THEN 
     1241                  knlaobs = knlaobs + 1 
     1242                  IF (ld_nea) THEN    
     1243                     kobsqc(jobsp) = kobsqc(jobsp) + 14  
     1244                  ENDIF  
     1245               ENDIF 
    18401246            ENDIF 
    1841  
     1247             
    18421248            ! For observations on the grid reject them if their are at 
    18431249            ! a masked point 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90

    r2715 r6069  
    104104      ! Bookkeeping arrays with sizes equal to number of variables 
    105105 
     106      CHARACTER(len=6), POINTER, DIMENSION(:) :: & 
     107         & cvars          !: Variable names 
     108 
    106109      INTEGER, POINTER, DIMENSION(:) :: & 
    107110         & nvprot,   &    !: Local total number of profile T data 
    … …  
    237240 
    238241      ALLOCATE( & 
     242         & prof%cvars(kvar),    & 
    239243         & prof%nvprot(kvar),   & 
    240244         & prof%nvprotmpp(kvar) & 
    … …  
    242246          
    243247      DO jvar = 1, kvar 
     248         prof%cvars    (jvar) = "NotSet" 
    244249         prof%nvprot   (jvar) = ko3dt(jvar) 
    245250         prof%nvprotmpp(jvar) = 0 
    … …  
    452457 
    453458      DEALLOCATE( & 
    454          & prof%nvprot,  & 
     459         & prof%cvars,    & 
     460         & prof%nvprot,   & 
    455461         & prof%nvprotmpp & 
    456462         ) 
    … …  
    770776      newprof%npj      = prof%npj 
    771777      newprof%npk      = prof%npk 
     778      newprof%cvars(:) = prof%cvars(:) 
    772779  
    773780      ! Deallocate temporary data 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_altbias.F90

    r3294 r6069  
    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 
    … …  
    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/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90

    r4990 r6069  
    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      &                     ldvar1, ldvar2, ldignmis, ldsatt, & 
     48      &                     ldmod, 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, INTENT(IN) :: ldvar1     ! Observed variables switches 
     77      LOGICAL, INTENT(IN) :: ldvar2 
     78      LOGICAL, INTENT(IN) :: ldignmis   ! Ignore missing files 
     79      LOGICAL, INTENT(IN) :: ldsatt     ! Compute salinity at all temperature points 
     80      LOGICAL, INTENT(IN) :: ldmod      ! Initialize model from input data 
     81      REAL(dp), INTENT(IN) :: ddobsini  ! Obs. ini time in YYYYMMDD.HHMMSS 
     82      REAL(dp), INTENT(IN) :: ddobsend  ! Obs. end time in YYYYMMDD.HHMMSS 
    8783      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    88          & kdailyavtypes 
     84         & kdailyavtypes                ! Types of daily average observations 
    8985 
    9086      !! * Local declarations 
    91       CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_pro_dri' 
     87      CHARACTER(LEN=15), PARAMETER :: cpname='obs_rea_prof' 
     88      CHARACTER(len=8) :: clrefdate 
     89      CHARACTER(len=6), DIMENSION(:), ALLOCATABLE :: clvars 
    9290      INTEGER :: jvar 
    9391      INTEGER :: ji 
    … …  
    105103      INTEGER :: imin 
    106104      INTEGER :: isec 
     105      INTEGER :: iprof 
     106      INTEGER :: iproftot 
     107      INTEGER :: ivar1t0 
     108      INTEGER :: ivar2t0 
     109      INTEGER :: ivar1t 
     110      INTEGER :: ivar2t 
     111      INTEGER :: ip3dt 
     112      INTEGER :: ios 
     113      INTEGER :: ioserrcount 
     114      INTEGER :: ivar1tmpp 
     115      INTEGER :: ivar2tmpp 
     116      INTEGER :: ip3dtmpp 
     117      INTEGER :: itype 
    107118      INTEGER, DIMENSION(knumfiles) :: & 
    108119         & irefdate 
    109120      INTEGER, DIMENSION(ntyp1770+1) :: & 
    110          & itypt,    & 
    111          & ityptmpp, & 
    112          & ityps,    & 
    113          & itypsmpp  
    114       INTEGER :: it3dtmpp 
    115       INTEGER :: is3dtmpp 
    116       INTEGER :: ip3dtmpp 
     121         & itypvar1,    & 
     122         & itypvar1mpp, & 
     123         & itypvar2,    & 
     124         & itypvar2mpp  
    117125      INTEGER, DIMENSION(:), ALLOCATABLE :: & 
    118          & iobsi,    & 
    119          & iobsj,    & 
    120          & iproc,    & 
     126         & iobsi1,    & 
     127         & iobsj1,    & 
     128         & iproc1,    & 
     129         & iobsi2,    & 
     130         & iobsj2,    & 
     131         & iproc2,    & 
    121132         & iindx,    & 
    122133         & ifileidx, & 
    123134         & iprofidx 
    124       INTEGER :: itype 
    125135      INTEGER, DIMENSION(imaxavtypes) :: & 
    126136         & idailyavtypes 
     137      INTEGER, DIMENSION(kvars) :: & 
     138         & iv3dt 
    127139      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    128140         & zphi, & 
    129141         & zlam 
    130       real(wp), DIMENSION(:), ALLOCATABLE :: & 
     142      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    131143         & zdat 
     144      REAL(wp), DIMENSION(knumfiles) :: & 
     145         & djulini, & 
     146         & djulend 
    132147      LOGICAL :: llvalprof 
     148      LOGICAL :: lldavtimset 
    133149      TYPE(obfbdata), POINTER, DIMENSION(:) :: & 
    134150         & 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     
     151 
    151152      ! Local initialization 
    152153      iprof = 0 
    153       it3dt0 = 0 
    154       is3dt0 = 0 
     154      ivar1t0 = 0 
     155      ivar2t0 = 0 
    155156      ip3dt = 0 
    156157 
    157158      ! Daily average types 
     159      lldavtimset = .FALSE. 
    158160      IF ( PRESENT(kdailyavtypes) ) THEN 
    159161         idailyavtypes(:) = kdailyavtypes(:) 
     162         IF ( ANY (idailyavtypes(:) /= -1) ) lldavtimset = .TRUE. 
    160163      ELSE 
    161164         idailyavtypes(:) = -1 
    … …  
    163166 
    164167      !----------------------------------------------------------------------- 
    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       !----------------------------------------------------------------------- 
    173168      ! Count the number of files needed and allocate the obfbdata type 
    174169      !----------------------------------------------------------------------- 
    175        
     170 
    176171      inobf = knumfiles 
    177        
     172 
    178173      ALLOCATE( inpfiles(inobf) ) 
    179174 
    180175      prof_files : DO jj = 1, inobf 
    181            
     176 
    182177         !--------------------------------------------------------------------- 
    183178         ! Prints 
    … …  
    186181            WRITE(numout,*) 
    187182            WRITE(numout,*) ' obs_rea_pro_dri : Reading from file = ', & 
    188                & TRIM( TRIM( cfilenames(jj) ) ) 
     183               & TRIM( TRIM( cdfilenames(jj) ) ) 
    189184            WRITE(numout,*) ' ~~~~~~~~~~~~~~~' 
    190185            WRITE(numout,*) 
    … …  
    194189         !  Initialization: Open file and get dimensions only 
    195190         !--------------------------------------------------------------------- 
    196           
    197          iflag = nf90_open( TRIM( TRIM( cfilenames(jj) ) ), nf90_nowrite, & 
     191 
     192         iflag = nf90_open( TRIM( cdfilenames(jj) ), nf90_nowrite, & 
    198193            &                      i_file_id ) 
    199           
     194 
    200195         IF ( iflag /= nf90_noerr ) THEN 
    201196 
    202197            IF ( ldignmis ) THEN 
    203198               inpfiles(jj)%nobs = 0 
    204                CALL ctl_warn( 'File ' // TRIM( TRIM( cfilenames(jj) ) ) // & 
     199               CALL ctl_warn( 'File ' // TRIM( cdfilenames(jj) ) // & 
    205200                  &           ' not found' ) 
    206201            ELSE  
    207                CALL ctl_stop( 'File ' // TRIM( TRIM( cfilenames(jj) ) ) // & 
     202               CALL ctl_stop( 'File ' // TRIM( cdfilenames(jj) ) // & 
    208203                  &           ' not found' ) 
    209204            ENDIF 
    210205 
    211206         ELSE  
    212              
     207 
    213208            !------------------------------------------------------------------ 
    214             !  Close the file since it is opened in read_proffile 
     209            !  Close the file since it is opened in read_obfbdata 
    215210            !------------------------------------------------------------------ 
    216              
     211 
    217212            iflag = nf90_close( i_file_id ) 
    218213 
    … …  
    220215            !  Read the profile file into inpfiles 
    221216            !------------------------------------------------------------------ 
    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. ) 
     217            CALL init_obfbdata( inpfiles(jj) ) 
     218            CALL read_obfbdata( TRIM( cdfilenames(jj) ), inpfiles(jj), & 
     219               &                ldgrid = .TRUE. ) 
     220 
     221            IF ( inpfiles(jj)%nvar < 2 ) THEN 
     222               CALL ctl_stop( 'Feedback format error: ', & 
     223                  &           ' less than 2 vars in profile file' ) 
     224            ENDIF 
     225 
     226            IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 
     227               CALL ctl_stop( 'Model not in input data' ) 
     228            ENDIF 
     229 
     230            IF ( jj == 1 ) THEN 
     231               ALLOCATE( clvars( inpfiles(jj)%nvar ) ) 
     232               DO ji = 1, inpfiles(jj)%nvar 
     233                 clvars(ji) = inpfiles(jj)%cname(ji) 
     234               END DO 
    253235            ELSE 
    254                CALL ctl_stop( 'File format unknown' ) 
    255             ENDIF 
    256              
     236               DO ji = 1, inpfiles(jj)%nvar 
     237                  IF ( inpfiles(jj)%cname(ji) /= clvars(ji) ) THEN 
     238                     CALL ctl_stop( 'Feedback file variables not consistent', & 
     239                        &           ' with previous files for this type' ) 
     240                  ENDIF 
     241               END DO 
     242            ENDIF 
     243 
    257244            !------------------------------------------------------------------ 
    258245            !  Change longitude (-180,180) 
    … …  
    272259            !  Calculate the date  (change eventually) 
    273260            !------------------------------------------------------------------ 
    274             cl_refdate=inpfiles(jj)%cdjuldref(1:8) 
    275             READ(cl_refdate,'(I8)') irefdate(jj) 
    276              
     261            clrefdate=inpfiles(jj)%cdjuldref(1:8) 
     262            READ(clrefdate,'(I8)') irefdate(jj) 
     263 
    277264            CALL ddatetoymdhms( ddobsini, iyea, imon, iday, ihou, imin, isec ) 
    278265            CALL greg2jul( isec, imin, ihou, iday, imon, iyea, djulini(jj), & 
    … …  
    283270 
    284271            ioserrcount=0 
    285             IF ( ldavtimset ) THEN 
     272            IF ( lldavtimset ) THEN 
     273 
     274               IF ( ANY ( idailyavtypes(:) /= -1 ) .AND. lwp) THEN 
     275                  WRITE(numout,*)' Resetting time of daily averaged', & 
     276                     &           ' observations to the end of the day' 
     277               ENDIF 
     278 
    286279               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                   ! 
    292280                  READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 900 ) itype 
    293281900               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 
     282                     ! Set type to zero if there is a problem in the string conversion 
     283                     itype = 0 
     284                  ENDIF 
     285 
     286                  IF ( ANY ( idailyavtypes(:) == itype ) ) THEN 
     287                  !  for daily averaged data force the time 
     288                  !  to be the last time-step of the day, but still within the day. 
     289                     IF ( inpfiles(jj)%ptim(ji) >= 0. ) THEN 
     290                        inpfiles(jj)%ptim(ji) = & 
     291                           & INT(inpfiles(jj)%ptim(ji)) + 0.9999 
     292                     ELSE 
     293                        inpfiles(jj)%ptim(ji) = & 
     294                           & INT(inpfiles(jj)%ptim(ji)) - 0.0001 
     295                     ENDIF 
     296                  ENDIF 
     297 
    300298               END DO 
    301             ENDIF 
    302              
     299 
     300            ENDIF 
     301 
    303302            IF ( inpfiles(jj)%nobs > 0 ) THEN 
    304                inpfiles(jj)%iproc = -1 
    305                inpfiles(jj)%iobsi = -1 
    306                inpfiles(jj)%iobsj = -1 
     303               inpfiles(jj)%iproc(:,:) = -1 
     304               inpfiles(jj)%iobsi(:,:) = -1 
     305               inpfiles(jj)%iobsj(:,:) = -1 
    307306            ENDIF 
    308307            inowin = 0 
    … …  
    318317            ALLOCATE( zlam(inowin)  ) 
    319318            ALLOCATE( zphi(inowin)  ) 
    320             ALLOCATE( iobsi(inowin) ) 
    321             ALLOCATE( iobsj(inowin) ) 
    322             ALLOCATE( iproc(inowin) ) 
     319            ALLOCATE( iobsi1(inowin) ) 
     320            ALLOCATE( iobsj1(inowin) ) 
     321            ALLOCATE( iproc1(inowin) ) 
     322            ALLOCATE( iobsi2(inowin) ) 
     323            ALLOCATE( iobsj2(inowin) ) 
     324            ALLOCATE( iproc2(inowin) ) 
    323325            inowin = 0 
    324326            DO ji = 1, inpfiles(jj)%nobs 
    … …  
    334336            END DO 
    335337 
    336             CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 
     338            IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 
     339               CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 
     340                  &                  iproc1, 'T' ) 
     341               iobsi2(:) = iobsi1(:) 
     342               iobsj2(:) = iobsj1(:) 
     343               iproc2(:) = iproc1(:) 
     344            ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN 
     345               CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & 
     346                  &                  iproc1, 'U' ) 
     347               CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, & 
     348                  &                  iproc2, 'V' ) 
     349            ENDIF 
    337350 
    338351            inowin = 0 
    … …  
    344357                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    345358                  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) 
     359                  inpfiles(jj)%iproc(ji,1) = iproc1(inowin) 
     360                  inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) 
     361                  inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) 
     362                  inpfiles(jj)%iproc(ji,2) = iproc2(inowin) 
     363                  inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) 
     364                  inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) 
     365                  IF ( inpfiles(jj)%iproc(ji,1) /= & 
     366                     & inpfiles(jj)%iproc(ji,2) ) THEN 
     367                     CALL ctl_stop( 'Error in obs_read_prof:', & 
     368                        & 'var1 and var2 observation on different processors') 
     369                  ENDIF 
    349370               ENDIF 
    350371            END DO 
    351             DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 
     372            DEALLOCATE( zlam, zphi, iobsi1, iobsj1, iproc1, iobsi2, iobsj2, iproc2 ) 
    352373 
    353374            DO ji = 1, inpfiles(jj)%nobs 
    … …  
    363384                  ENDIF 
    364385                  llvalprof = .FALSE. 
    365                   IF ( ldt3d ) THEN 
     386                  IF ( ldvar1 ) THEN 
    366387                     loop_t_count : DO ij = 1,inpfiles(jj)%nlev 
    367388                        IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    … …  
    369390                        IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    370391                           & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    371                            it3dt0 = it3dt0 + 1 
     392                           ivar1t0 = ivar1t0 + 1 
    372393                        ENDIF 
    373394                     END DO loop_t_count 
    374395                  ENDIF 
    375                   IF ( lds3d ) THEN 
     396                  IF ( ldvar2 ) THEN 
    376397                     loop_s_count : DO ij = 1,inpfiles(jj)%nlev 
    377398                        IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    … …  
    379400                        IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    380401                           & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    381                            is3dt0 = is3dt0 + 1 
     402                           ivar2t0 = ivar2t0 + 1 
    382403                        ENDIF 
    383404                     END DO loop_s_count 
    … …  
    388409                     IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    389410                        &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    390                         &     ldt3d ) .OR. & 
     411                        &     ldvar1 ) .OR. & 
    391412                        & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    392413                        &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    393                         &     lds3d ) ) THEN 
     414                        &     ldvar2 ) ) THEN 
    394415                        ip3dt = ip3dt + 1 
    395416                        llvalprof = .TRUE. 
    … …  
    405426 
    406427      END DO prof_files 
    407        
     428 
    408429      !----------------------------------------------------------------------- 
    409430      ! Get the time ordered indices of the input data 
    … …  
    446467         &               zdat,     & 
    447468         &               iindx   ) 
    448        
     469 
    449470      iv3dt(:) = -1 
    450471      IF (ldsatt) THEN 
    … …  
    452473         iv3dt(2) = ip3dt 
    453474      ELSE 
    454          iv3dt(1) = it3dt0 
    455          iv3dt(2) = is3dt0 
     475         iv3dt(1) = ivar1t0 
     476         iv3dt(2) = ivar2t0 
    456477      ENDIF 
    457478      CALL obs_prof_alloc( profdata, kvars, kextr, iprof, iv3dt, & 
    458479         &                 kstp, jpi, jpj, jpk ) 
    459        
     480 
    460481      ! * Read obs/positions, QC, all variable and assign to profdata 
    461482 
    462483      profdata%nprof     = 0 
    463484      profdata%nvprot(:) = 0 
    464  
     485      profdata%cvars(:)  = clvars(:) 
    465486      iprof = 0 
    466487 
    467488      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       
     489      ivar1t = 0 
     490      ivar2t = 0 
     491      itypvar1   (:) = 0 
     492      itypvar1mpp(:) = 0 
     493 
     494      itypvar2   (:) = 0 
     495      itypvar2mpp(:) = 0 
     496 
     497      ioserrcount = 0 
    477498      DO jk = 1, iproftot 
    478           
     499 
    479500         jj = ifileidx(iindx(jk)) 
    480501         ji = iprofidx(iindx(jk)) 
    … …  
    486507         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  & 
    487508            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    488              
     509 
    489510            IF ( nproc == 0 ) THEN 
    490511               IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE 
    … …  
    492513               IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
    493514            ENDIF 
    494              
     515 
    495516            llvalprof = .FALSE. 
    496517 
    … …  
    501522 
    502523            loop_prof : DO ij = 1, inpfiles(jj)%nlev 
    503                 
     524 
    504525               IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    505526                  & CYCLE 
    506                 
     527 
    507528               IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    508529                  & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    509                    
     530 
    510531                  llvalprof = .TRUE.  
    511532                  EXIT loop_prof 
    512                    
     533 
    513534               ENDIF 
    514                 
     535 
    515536               IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    516537                  & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    517                    
     538 
    518539                  llvalprof = .TRUE.  
    519540                  EXIT loop_prof 
    520                    
     541 
    521542               ENDIF 
    522                 
     543 
    523544            END DO loop_prof 
    524              
     545 
    525546            ! Set profile information 
    526              
     547 
    527548            IF ( llvalprof ) THEN 
    528                 
     549 
    529550               iprof = iprof + 1 
    530551 
    … …  
    545566               profdata%nhou(iprof) = ihou 
    546567               profdata%nmin(iprof) = imin 
    547                 
     568 
    548569               ! Profile space coordinates 
    549570               profdata%rlam(iprof) = inpfiles(jj)%plam(ji) 
    … …  
    551572 
    552573               ! Coordinate search parameters 
    553                profdata%mi  (iprof,:) = inpfiles(jj)%iobsi(ji,1) 
    554                profdata%mj  (iprof,:) = inpfiles(jj)%iobsj(ji,1) 
    555                 
     574               profdata%mi  (iprof,1) = inpfiles(jj)%iobsi(ji,1) 
     575               profdata%mj  (iprof,1) = inpfiles(jj)%iobsj(ji,1) 
     576               profdata%mi  (iprof,2) = inpfiles(jj)%iobsi(ji,2) 
     577               profdata%mj  (iprof,2) = inpfiles(jj)%iobsj(ji,2) 
     578 
    556579               ! Profile WMO number 
    557580               profdata%cwmo(iprof) = inpfiles(jj)%cdwmo(ji) 
    558                 
     581 
    559582               ! Instrument type 
    560583               READ( inpfiles(jj)%cdtyp(ji), '(I4)', IOSTAT = ios, ERR = 901 ) itype 
    … …  
    564587                  itype = 0 
    565588               ENDIF 
    566                 
     589 
    567590               profdata%ntyp(iprof) = itype 
    568                 
     591 
    569592               ! QC stuff 
    570593 
    … …  
    585608               profdata%nqc(iprof)  = 0 !TODO 
    586609 
    587                loop_p : DO ij = 1, inpfiles(jj)%nlev             
    588                    
     610               loop_p : DO ij = 1, inpfiles(jj)%nlev 
     611 
    589612                  IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & 
    590613                     & CYCLE 
    … …  
    594617                     IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    595618                        &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    596                         &     ldt3d ) .OR. & 
     619                        &     ldvar1 ) .OR. & 
    597620                        & ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    598621                        &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    599                         &     lds3d ) ) THEN 
     622                        &     ldvar2 ) ) THEN 
    600623                        ip3dt = ip3dt + 1 
    601624                     ELSE 
    602625                        CYCLE 
    603626                     ENDIF 
    604                       
     627 
    605628                  ENDIF 
    606629 
    607630                  IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    608631                     &     ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    609                      &       ldt3d ) .OR. ldsatt ) THEN 
    610                       
     632                     &       ldvar1 ) .OR. ldsatt ) THEN 
     633 
    611634                     IF (ldsatt) THEN 
    612635 
    613                         it3dt = ip3dt 
     636                        ivar1t = ip3dt 
    614637 
    615638                     ELSE 
    616639 
    617                         it3dt = it3dt + 1 
    618                          
     640                        ivar1t = ivar1t + 1 
     641 
    619642                     ENDIF 
    620643 
    621                      ! Depth of T observation 
    622                      profdata%var(1)%vdep(it3dt) = & 
     644                     ! Depth of var1 observation 
     645                     profdata%var(1)%vdep(ivar1t) = & 
    623646                        &                inpfiles(jj)%pdep(ij,ji) 
    624                       
    625                      ! Depth of T observation QC 
    626                      profdata%var(1)%idqc(it3dt) = & 
     647 
     648                     ! Depth of var1 observation QC 
     649                     profdata%var(1)%idqc(ivar1t) = & 
    627650                        &                inpfiles(jj)%idqc(ij,ji) 
    628                       
    629                      ! Depth of T observation QC flags 
    630                      profdata%var(1)%idqcf(:,it3dt) = & 
     651 
     652                     ! Depth of var1 observation QC flags 
     653                     profdata%var(1)%idqcf(:,ivar1t) = & 
    631654                        &                inpfiles(jj)%idqcf(:,ij,ji) 
    632                       
     655 
    633656                     ! Profile index 
    634                      profdata%var(1)%nvpidx(it3dt) = iprof 
    635                       
     657                     profdata%var(1)%nvpidx(ivar1t) = iprof 
     658 
    636659                     ! Vertical index in original profile 
    637                      profdata%var(1)%nvlidx(it3dt) = ij 
    638  
    639                      ! Profile potential T value 
     660                     profdata%var(1)%nvlidx(ivar1t) = ij 
     661 
     662                     ! Profile var1 value 
    640663                     IF ( ( inpfiles(jj)%ivlqc(ij,ji,1) <= 2 ) .AND. & 
    641664                        & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    642                         profdata%var(1)%vobs(it3dt) = & 
     665                        profdata%var(1)%vobs(ivar1t) = & 
    643666                           &                inpfiles(jj)%pob(ij,ji,1) 
    644667                        IF ( ldmod ) THEN 
    645                            profdata%var(1)%vmod(it3dt) = & 
     668                           profdata%var(1)%vmod(ivar1t) = & 
    646669                              &                inpfiles(jj)%padd(ij,ji,1,1) 
    647670                        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 
     671                        ! Count number of profile var1 data as function of type 
     672                        itypvar1( profdata%ntyp(iprof) + 1 ) = & 
     673                           & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 
    651674                     ELSE 
    652                         profdata%var(1)%vobs(it3dt) = fbrmdi 
     675                        profdata%var(1)%vobs(ivar1t) = fbrmdi 
    653676                     ENDIF 
    654677 
    655                      ! Profile T qc 
    656                      profdata%var(1)%nvqc(it3dt) = & 
     678                     ! Profile var1 qc 
     679                     profdata%var(1)%nvqc(ivar1t) = & 
    657680                        & inpfiles(jj)%ivlqc(ij,ji,1) 
    658681 
    659                      ! Profile T qc flags 
    660                      profdata%var(1)%nvqcf(:,it3dt) = & 
     682                     ! Profile var1 qc flags 
     683                     profdata%var(1)%nvqcf(:,ivar1t) = & 
    661684                        & inpfiles(jj)%ivlqcf(:,ij,ji,1) 
    662685 
    663686                     ! Profile insitu T value 
    664                      profdata%var(1)%vext(it3dt,1) = & 
    665                         &                inpfiles(jj)%pext(ij,ji,1) 
    666                       
    667                   ENDIF 
    668                    
     687                     IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN 
     688                        profdata%var(1)%vext(ivar1t,1) = & 
     689                           &                inpfiles(jj)%pext(ij,ji,1) 
     690                     ENDIF 
     691 
     692                  ENDIF 
     693 
    669694                  IF ( ( ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    670695                     &   ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) .AND. & 
    671                      &   lds3d ) .OR. ldsatt ) THEN 
    672                       
     696                     &   ldvar2 ) .OR. ldsatt ) THEN 
     697 
    673698                     IF (ldsatt) THEN 
    674699 
    675                         is3dt = ip3dt 
     700                        ivar2t = ip3dt 
    676701 
    677702                     ELSE 
    678703 
    679                         is3dt = is3dt + 1 
    680                          
     704                        ivar2t = ivar2t + 1 
     705 
    681706                     ENDIF 
    682707 
    683                      ! Depth of S observation 
    684                      profdata%var(2)%vdep(is3dt) = & 
     708                     ! Depth of var2 observation 
     709                     profdata%var(2)%vdep(ivar2t) = & 
    685710                        &                inpfiles(jj)%pdep(ij,ji) 
    686                       
    687                      ! Depth of S observation QC 
    688                      profdata%var(2)%idqc(is3dt) = & 
     711 
     712                     ! Depth of var2 observation QC 
     713                     profdata%var(2)%idqc(ivar2t) = & 
    689714                        &                inpfiles(jj)%idqc(ij,ji) 
    690                       
    691                      ! Depth of S observation QC flags 
    692                      profdata%var(2)%idqcf(:,is3dt) = & 
     715 
     716                     ! Depth of var2 observation QC flags 
     717                     profdata%var(2)%idqcf(:,ivar2t) = & 
    693718                        &                inpfiles(jj)%idqcf(:,ij,ji) 
    694                       
     719 
    695720                     ! Profile index 
    696                      profdata%var(2)%nvpidx(is3dt) = iprof 
    697                       
     721                     profdata%var(2)%nvpidx(ivar2t) = iprof 
     722 
    698723                     ! Vertical index in original profile 
    699                      profdata%var(2)%nvlidx(is3dt) = ij 
    700  
    701                      ! Profile S value 
     724                     profdata%var(2)%nvlidx(ivar2t) = ij 
     725 
     726                     ! Profile var2 value 
    702727                     IF ( ( inpfiles(jj)%ivlqc(ij,ji,2) <= 2 ) .AND. & 
    703728                        & ( inpfiles(jj)%idqc(ij,ji) <= 2 ) ) THEN 
    704                         profdata%var(2)%vobs(is3dt) = & 
     729                        profdata%var(2)%vobs(ivar2t) = & 
    705730                           &                inpfiles(jj)%pob(ij,ji,2) 
    706731                        IF ( ldmod ) THEN 
    707                            profdata%var(2)%vmod(is3dt) = & 
     732                           profdata%var(2)%vmod(ivar2t) = & 
    708733                              &                inpfiles(jj)%padd(ij,ji,1,2) 
    709734                        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 
     735                        ! Count number of profile var2 data as function of type 
     736                        itypvar2( profdata%ntyp(iprof) + 1 ) = & 
     737                           & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 
    713738                     ELSE 
    714                         profdata%var(2)%vobs(is3dt) = fbrmdi 
     739                        profdata%var(2)%vobs(ivar2t) = fbrmdi 
    715740                     ENDIF 
    716                       
    717                      ! Profile S qc 
    718                      profdata%var(2)%nvqc(is3dt) = & 
     741 
     742                     ! Profile var2 qc 
     743                     profdata%var(2)%nvqc(ivar2t) = & 
    719744                        & inpfiles(jj)%ivlqc(ij,ji,2) 
    720745 
    721                      ! Profile S qc flags 
    722                      profdata%var(2)%nvqcf(:,is3dt) = & 
     746                     ! Profile var2 qc flags 
     747                     profdata%var(2)%nvqcf(:,ivar2t) = & 
    723748                        & inpfiles(jj)%ivlqcf(:,ij,ji,2) 
    724749 
    725750                  ENDIF 
    726              
     751 
    727752               END DO loop_p 
    728753 
    … …  
    736761      ! Sum up over processors 
    737762      !----------------------------------------------------------------------- 
    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        
     763 
     764      CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) 
     765      CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) 
     766      CALL obs_mpp_sum_integer ( ip3dt,   ip3dtmpp ) 
     767 
     768      CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) 
     769      CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) 
     770 
    746771      !----------------------------------------------------------------------- 
    747772      ! Output number of observations. 
    … …  
    749774      IF(lwp) THEN 
    750775         WRITE(numout,*)  
    751          WRITE(numout,'(1X,A)') 'Profile data' 
     776         WRITE(numout,'(A)') ' Profile data' 
    752777         WRITE(numout,'(1X,A)') '------------' 
    753778         WRITE(numout,*)  
    754          WRITE(numout,'(1X,A)') 'Profile T data' 
    755          WRITE(numout,'(1X,A)') '--------------' 
     779         WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) 
     780         WRITE(numout,'(1X,A)') '------------------------' 
    756781         DO ji = 0, ntyp1770 
    757             IF ( ityptmpp(ji+1) > 0 ) THEN 
     782            IF ( itypvar1mpp(ji+1) > 0 ) THEN 
    758783               WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
    759784                  & cwmonam1770(ji)(1:52),' = ', & 
    760                   & ityptmpp(ji+1) 
     785                  & itypvar1mpp(ji+1) 
    761786            ENDIF 
    762787         END DO 
    … …  
    764789            & '---------------------------------------------------------------' 
    765790         WRITE(numout,'(1X,A55,I8)') & 
    766             & 'Total profile T data                                 = ',& 
    767             & it3dtmpp 
     791            & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & 
     792            & '             = ', ivar1tmpp 
    768793         WRITE(numout,'(1X,A)') & 
    769794            & '---------------------------------------------------------------' 
    770795         WRITE(numout,*)  
    771          WRITE(numout,'(1X,A)') 'Profile S data' 
    772          WRITE(numout,'(1X,A)') '--------------' 
     796         WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) 
     797         WRITE(numout,'(1X,A)') '------------------------' 
    773798         DO ji = 0, ntyp1770 
    774             IF ( itypsmpp(ji+1) > 0 ) THEN 
     799            IF ( itypvar2mpp(ji+1) > 0 ) THEN 
    775800               WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & 
    776801                  & cwmonam1770(ji)(1:52),' = ', & 
    777                   & itypsmpp(ji+1) 
     802                  & itypvar2mpp(ji+1) 
    778803            ENDIF 
    779804         END DO 
    … …  
    781806            & '---------------------------------------------------------------' 
    782807         WRITE(numout,'(1X,A55,I8)') & 
    783             & 'Total profile S data                                 = ',& 
    784             & is3dtmpp 
     808            & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// & 
     809            & '             = ', ivar2tmpp 
    785810         WRITE(numout,'(1X,A)') & 
    786811            & '---------------------------------------------------------------' 
    787812         WRITE(numout,*)  
    788813      ENDIF 
    789        
     814 
    790815      IF (ldsatt) THEN 
    791816         profdata%nvprot(1)    = ip3dt 
    … …  
    794819         profdata%nvprotmpp(2) = ip3dtmpp 
    795820      ELSE 
    796          profdata%nvprot(1)    = it3dt 
    797          profdata%nvprot(2)    = is3dt 
    798          profdata%nvprotmpp(1) = it3dtmpp 
    799          profdata%nvprotmpp(2) = is3dtmpp 
     821         profdata%nvprot(1)    = ivar1t 
     822         profdata%nvprot(2)    = ivar2t 
     823         profdata%nvprotmpp(1) = ivar1tmpp 
     824         profdata%nvprotmpp(2) = ivar2tmpp 
    800825      ENDIF 
    801826      profdata%nprof        = iprof 
    … …  
    804829      ! Model level search 
    805830      !----------------------------------------------------------------------- 
    806       IF ( ldt3d ) THEN 
     831      IF ( ldvar1 ) THEN 
    807832         CALL obs_level_search( jpk, gdept_1d, & 
    808833            & profdata%nvprot(1), profdata%var(1)%vdep, & 
    809834            & profdata%var(1)%mvk ) 
    810835      ENDIF 
    811       IF ( lds3d ) THEN 
     836      IF ( ldvar2 ) THEN 
    812837         CALL obs_level_search( jpk, gdept_1d, & 
    813838            & profdata%nvprot(2), profdata%var(2)%vdep, & 
    814839            & profdata%var(2)%mvk ) 
    815840      ENDIF 
    816        
     841 
    817842      !----------------------------------------------------------------------- 
    818843      ! Set model equivalent to 99999 
    … …  
    826851      ! Deallocate temporary data 
    827852      !----------------------------------------------------------------------- 
    828       DEALLOCATE( ifileidx, iprofidx, zdat ) 
     853      DEALLOCATE( ifileidx, iprofidx, zdat, clvars ) 
    829854 
    830855      !----------------------------------------------------------------------- 
    … …  
    836861      DEALLOCATE( inpfiles ) 
    837862 
    838    END SUBROUTINE obs_rea_pro_dri 
     863   END SUBROUTINE obs_rea_prof 
    839864 
    840865END MODULE obs_read_prof 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readmdt.F90

    r5836 r6069  
    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) = 11 
    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/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90

    r3294 r6069  
    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/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_surf_def.F90

    r3651 r6069  
    6767         & ntyp           !: Type of surface observation product 
    6868 
     69      CHARACTER(len=6), POINTER, DIMENSION(:) :: & 
     70         & cvars          !: Variable names 
     71 
    6972      CHARACTER(LEN=8), POINTER, DIMENSION(:) :: & 
    7073         & cwmo           !: WMO indentifier 
    … …  
    130133      !!* Local variables 
    131134      INTEGER :: ji 
     135      INTEGER :: jvar 
    132136 
    133137      ! Set bookkeeping variables 
    … …  
    140144      surf%npi      = kpi 
    141145      surf%npj      = kpj 
     146 
     147      ! Allocate arrays of size number of variables 
     148 
     149      ALLOCATE( & 
     150         & surf%cvars(kvar)    & 
     151         & ) 
     152 
     153      DO jvar = 1, kvar 
     154         surf%cvars(jvar) = "NotSet" 
     155      END DO 
    142156       
    143157      ! Allocate arrays of number of surface data size 
    … …  
    271285         & ) 
    272286 
     287      ! Dellocate arrays of size number of variables 
     288 
     289      DEALLOCATE( & 
     290         & surf%cvars     & 
     291         & ) 
     292 
    273293   END SUBROUTINE obs_surf_dealloc 
    274294 
    … …  
    392412      ! Set book keeping variables which do not depend on number of obs. 
    393413 
    394       newsurf%nstp  = surf%nstp 
     414      newsurf%nstp     = surf%nstp 
     415      newsurf%cvars(:) = surf%cvars(:) 
    395416  
    396417      ! Deallocate temporary data 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_types.F90

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

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90

    r4990 r6069  
    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 
     8   !!   obs_wri_prof   : Write profile observations in feedback format 
     9   !!   obs_wri_surf   : Write surface observations in feedback format 
    1310   !!   obs_wri_stats : Print basic statistics on the data being written out 
    1411   !!---------------------------------------------------------------------- 
    … …  
    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=6) :: clfiletype 
    9786      INTEGER :: ilevel 
    9887      INTEGER :: jvar 
    … …  
    10291      INTEGER :: ja 
    10392      INTEGER :: je 
     93      INTEGER :: iadd 
     94      INTEGER :: iext 
    10495      REAL(wp) :: zpres 
    105       INTEGER :: nadd 
    106       INTEGER :: next 
    10796 
    10897      IF ( PRESENT( padd ) ) THEN 
    109          nadd = padd%inum 
     98         iadd = padd%inum 
    11099      ELSE 
    111          nadd = 0 
     100         iadd = 0 
    112101      ENDIF 
    113102 
    114103      IF ( PRESENT( pext ) ) THEN 
    115          next = pext%inum 
     104         iext = pext%inum 
    116105      ELSE 
    117          next = 0 
    118       ENDIF 
    119        
     106         iext = 0 
     107      ENDIF 
     108 
    120109      CALL init_obfbdata( fbdata ) 
    121110 
    … …  
    125114         ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 
    126115      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 
     116 
     117      SELECT CASE ( TRIM(profdata%cvars(1)) ) 
     118      CASE('POTM') 
     119 
     120         clfiletype='profb' 
     121         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 
     122            &                 1 + iadd, 1 + iext, .TRUE. ) 
     123         fbdata%cname(1)      = profdata%cvars(1) 
     124         fbdata%cname(2)      = profdata%cvars(2) 
     125         fbdata%coblong(1)    = 'Potential temperature' 
     126         fbdata%coblong(2)    = 'Practical salinity' 
     127         fbdata%cobunit(1)    = 'Degrees centigrade' 
     128         fbdata%cobunit(2)    = 'PSU' 
     129         fbdata%cextname(1)   = 'TEMP' 
     130         fbdata%cextlong(1)   = 'Insitu temperature' 
     131         fbdata%cextunit(1)   = 'Degrees centigrade' 
     132         fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 
     133         fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 
     134         fbdata%caddunit(1,1) = 'Degrees centigrade' 
     135         fbdata%caddunit(1,2) = 'PSU' 
     136         fbdata%cgrid(:)      = 'T' 
     137         DO je = 1, iext 
     138            fbdata%cextname(1+je) = pext%cdname(je) 
     139            fbdata%cextlong(1+je) = pext%cdlong(je,1) 
     140            fbdata%cextunit(1+je) = pext%cdunit(je,1) 
     141         END DO 
     142         DO ja = 1, iadd 
     143            fbdata%caddname(1+ja) = padd%cdname(ja) 
     144            DO jvar = 1, 2 
     145               fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 
     146               fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 
     147            END DO 
     148         END DO 
     149 
     150      CASE('UVEL') 
     151 
     152         clfiletype='velfb' 
     153         CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) 
     154         fbdata%cname(1)      = profdata%cvars(1) 
     155         fbdata%cname(2)      = profdata%cvars(2) 
     156         fbdata%coblong(1)    = 'Zonal velocity' 
     157         fbdata%coblong(2)    = 'Meridional velocity' 
     158         fbdata%cobunit(1)    = 'm/s' 
     159         fbdata%cobunit(2)    = 'm/s' 
     160         DO je = 1, iext 
     161            fbdata%cextname(je) = pext%cdname(je) 
     162            fbdata%cextlong(je) = pext%cdlong(je,1) 
     163            fbdata%cextunit(je) = pext%cdunit(je,1) 
     164         END DO 
     165         fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 
     166         fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 
     167         fbdata%caddunit(1,1) = 'm/s' 
     168         fbdata%caddunit(1,2) = 'm/s' 
     169         fbdata%cgrid(1)      = 'U'  
     170         fbdata%cgrid(2)      = 'V' 
     171         DO ja = 1, iadd 
     172            fbdata%caddname(1+ja) = padd%cdname(ja) 
     173            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     174            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     175         END DO 
     176 
     177      END SELECT 
     178 
    144179      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 
     180 
     181      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
    159182 
    160183      IF(lwp) THEN 
    161184         WRITE(numout,*) 
    162          WRITE(numout,*)'obs_wri_p3d :' 
     185         WRITE(numout,*)'obs_wri_prof :' 
    163186         WRITE(numout,*)'~~~~~~~~~~~~~' 
    164          WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname) 
    165       ENDIF 
    166  
    167       ! Transform obs_prof data structure into obfbdata structure 
     187         WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 
     188      ENDIF 
     189 
     190      ! Transform obs_prof data structure into obfb data structure 
    168191      fbdata%cdjuldref = '19500101000000' 
    169192      DO jo = 1, profdata%nprof 
    … …  
    222245               ENDIF 
    223246               fbdata%iobsk(ik,jo,jvar)  = profdata%var(jvar)%mvk(jk) 
    224                DO ja = 1, nadd 
     247               DO ja = 1, iadd 
    225248                  fbdata%padd(ik,jo,1+ja,jvar) = & 
    226249                     & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 
    227250               END DO 
    228                DO je = 1, next 
     251               DO je = 1, iext 
    229252                  fbdata%pext(ik,jo,1+je) = & 
    230253                     & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 
    231254               END DO 
    232                IF ( jvar == 1 ) THEN 
     255               IF ( ( jvar == 1 ) .AND. & 
     256                  & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 
    233257                  fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 
    234258               ENDIF  
    … …  
    237261      END DO 
    238262 
    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        
     263      IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 
     264         ! Convert insitu temperature to potential temperature using the model 
     265         ! salinity if no potential temperature 
     266         DO jo = 1, fbdata%nobs 
     267            IF ( fbdata%pphi(jo) < 9999.0 ) THEN 
     268               DO jk = 1, fbdata%nlev 
     269                  IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 
     270                     & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
     271                     & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 
     272                     & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 
     273                     zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 
     274                        &              REAL(fbdata%pphi(jo),wp) ) 
     275                     fbdata%pob(jk,jo,1) = potemp( & 
     276                        &                     REAL(fbdata%padd(jk,jo,1,2), wp),  & 
     277                        &                     REAL(fbdata%pext(jk,jo,1), wp), & 
     278                        &                     zpres, 0.0_wp ) 
     279                  ENDIF 
     280               END DO 
     281            ENDIF 
     282         END DO 
     283      ENDIF 
     284 
    259285      ! Write the obfbdata structure 
    260       CALL write_obfbdata( cfname, fbdata ) 
     286      CALL write_obfbdata( clfname, fbdata ) 
    261287 
    262288      ! Output some basic statistics 
    … …  
    264290 
    265291      CALL dealloc_obfbdata( fbdata ) 
    266       
    267    END SUBROUTINE obs_wri_p3d 
    268  
    269    SUBROUTINE obs_wri_sla( cprefix, sladata, padd, pext ) 
     292 
     293   END SUBROUTINE obs_wri_prof 
     294 
     295   SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 
    270296      !!----------------------------------------------------------------------- 
    271297      !! 
    272       !!                     *** ROUTINE obs_wri_sla  *** 
    273       !! 
    274       !! ** Purpose : Write SLA observation diagnostics 
    275       !!              related  
     298      !!                     *** ROUTINE obs_wri_surf  *** 
     299      !! 
     300      !! ** Purpose : Write surface observation files 
    276301      !! 
    277302      !! ** Method  : NetCDF 
    … …  
    281306      !!      ! 07-03  (K. Mogensen) Original 
    282307      !!      ! 09-01  (K. Mogensen) New feedback format. 
     308      !!      ! 15-02  (M. Martin) Combined surface writing routine. 
    283309      !!----------------------------------------------------------------------- 
    284310 
    … …  
    287313 
    288314      !! * Arguments 
    289       CHARACTER(LEN=*), INTENT(IN) :: cprefix          ! Prefix for output files 
    290       TYPE(obs_surf), INTENT(INOUT) :: sladata         ! Full set of SLAa 
     315      TYPE(obs_surf), INTENT(INOUT) :: surfdata         ! Full set of surface data 
    291316      TYPE(obswriinfo), OPTIONAL :: padd               ! Additional info for each variable 
    292317      TYPE(obswriinfo), OPTIONAL :: pext               ! Extra info 
    … …  
    294319      !! * Local declarations 
    295320      TYPE(obfbdata) :: fbdata 
    296       CHARACTER(LEN=40) :: cfname         ! netCDF filename 
    297       CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 
     321      CHARACTER(LEN=40) :: clfname         ! netCDF filename 
     322      CHARACTER(LEN=6)  :: clfiletype 
     323      CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 
    298324      INTEGER :: jo 
    299325      INTEGER :: ja 
    300326      INTEGER :: je 
    301       INTEGER :: nadd 
    302       INTEGER :: next 
     327      INTEGER :: iadd 
     328      INTEGER :: iext 
    303329 
    304330      IF ( PRESENT( padd ) ) THEN 
    305          nadd = padd%inum 
     331         iadd = padd%inum 
    306332      ELSE 
    307          nadd = 0 
     333         iadd = 0 
    308334      ENDIF 
    309335 
    310336      IF ( PRESENT( pext ) ) THEN 
    311          next = pext%inum 
     337         iext = pext%inum 
    312338      ELSE 
    313          next = 0 
     339         iext = 0 
    314340      ENDIF 
    315341 
    316342      CALL init_obfbdata( fbdata ) 
    317343 
    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 
     344      SELECT CASE ( TRIM(surfdata%cvars(1)) ) 
     345      CASE('SLA') 
     346 
     347         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     348            &                 2 + iadd, 1 + iext, .TRUE. ) 
     349 
     350         clfiletype = 'slafb' 
     351         fbdata%cname(1)      = surfdata%cvars(1) 
     352         fbdata%coblong(1)    = 'Sea level anomaly' 
     353         fbdata%cobunit(1)    = 'Metres' 
     354         fbdata%cextname(1)   = 'MDT' 
     355         fbdata%cextlong(1)   = 'Mean dynamic topography' 
     356         fbdata%cextunit(1)   = 'Metres' 
     357         DO je = 1, iext 
     358            fbdata%cextname(je) = pext%cdname(je) 
     359            fbdata%cextlong(je) = pext%cdlong(je,1) 
     360            fbdata%cextunit(je) = pext%cdunit(je,1) 
     361         END DO 
     362         fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 
     363         fbdata%caddunit(1,1) = 'Metres'  
     364         fbdata%caddname(2)   = 'SSH' 
     365         fbdata%caddlong(2,1) = 'Model Sea surface height' 
     366         fbdata%caddunit(2,1) = 'Metres' 
     367         fbdata%cgrid(1)      = 'T' 
     368         DO ja = 1, iadd 
     369            fbdata%caddname(2+ja) = padd%cdname(ja) 
     370            fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 
     371            fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 
     372         END DO 
     373 
     374      CASE('SST') 
     375 
     376         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     377            &                 1 + iadd, iext, .TRUE. ) 
     378 
     379         clfiletype = 'sstfb' 
     380         fbdata%cname(1)      = surfdata%cvars(1) 
     381         fbdata%coblong(1)    = 'Sea surface temperature' 
     382         fbdata%cobunit(1)    = 'Degree centigrade' 
     383         DO je = 1, iext 
     384            fbdata%cextname(je) = pext%cdname(je) 
     385            fbdata%cextlong(je) = pext%cdlong(je,1) 
     386            fbdata%cextunit(je) = pext%cdunit(je,1) 
     387         END DO 
     388         fbdata%caddlong(1,1) = 'Model interpolated SST' 
     389         fbdata%caddunit(1,1) = 'Degree centigrade' 
     390         fbdata%cgrid(1)      = 'T' 
     391         DO ja = 1, iadd 
     392            fbdata%caddname(1+ja) = padd%cdname(ja) 
     393            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     394            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     395         END DO 
     396 
     397      CASE('ICECON') 
     398 
     399         CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 
     400            &                 1 + iadd, iext, .TRUE. ) 
     401 
     402         clfiletype = 'sicfb' 
     403         fbdata%cname(1)      = surfdata%cvars(1) 
     404         fbdata%coblong(1)    = 'Sea ice' 
     405         fbdata%cobunit(1)    = 'Fraction' 
     406         DO je = 1, iext 
     407            fbdata%cextname(je) = pext%cdname(je) 
     408            fbdata%cextlong(je) = pext%cdlong(je,1) 
     409            fbdata%cextunit(je) = pext%cdunit(je,1) 
     410         END DO 
     411         fbdata%caddlong(1,1) = 'Model interpolated ICE' 
     412         fbdata%caddunit(1,1) = 'Fraction' 
     413         fbdata%cgrid(1)      = 'T' 
     414         DO ja = 1, iadd 
     415            fbdata%caddname(1+ja) = padd%cdname(ja) 
     416            fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 
     417            fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
     418         END DO 
     419 
     420      END SELECT 
     421 
    332422      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 
     423 
     424      WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 
    346425 
    347426      IF(lwp) THEN 
    348427         WRITE(numout,*) 
    349          WRITE(numout,*)'obs_wri_sla :' 
     428         WRITE(numout,*)'obs_wri_surf :' 
    350429         WRITE(numout,*)'~~~~~~~~~~~~~' 
    351          WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname) 
    352       ENDIF 
    353  
    354       ! Transform obs_prof data structure into obfbdata structure 
     430         WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 
     431      ENDIF 
     432 
     433      ! Transform surf data structure into obfbdata structure 
    355434      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) 
     435      DO jo = 1, surfdata%nsurf 
     436         fbdata%plam(jo)      = surfdata%rlam(jo) 
     437         fbdata%pphi(jo)      = surfdata%rphi(jo) 
     438         WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 
    360439         fbdata%ivqc(jo,:)    = 0 
    361440         fbdata%ivqcf(:,jo,:) = 0 
    362          IF ( sladata%nqc(jo) > 10 ) THEN 
     441         IF ( surfdata%nqc(jo) > 10 ) THEN 
    363442            fbdata%ioqc(jo)    = 4 
    364443            fbdata%ioqcf(1,jo) = 0 
    365             fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10 
     444            fbdata%ioqcf(2,jo) = surfdata%nqc(jo) - 10 
    366445         ELSE 
    367             fbdata%ioqc(jo)    = sladata%nqc(jo) 
     446            fbdata%ioqc(jo)    = surfdata%nqc(jo) 
    368447            fbdata%ioqcf(:,jo) = 0 
    369448         ENDIF 
    … …  
    372451         fbdata%itqc(jo)      = 0 
    373452         fbdata%itqcf(:,jo)   = 0 
    374          fbdata%cdwmo(jo)     = sladata%cwmo(jo) 
    375          fbdata%kindex(jo)    = sladata%nsfil(jo) 
     453         fbdata%cdwmo(jo)     = surfdata%cwmo(jo) 
     454         fbdata%kindex(jo)    = surfdata%nsfil(jo) 
    376455         IF (ln_grid_global) THEN 
    377             fbdata%iobsi(jo,1) = sladata%mi(jo) 
    378             fbdata%iobsj(jo,1) = sladata%mj(jo) 
     456            fbdata%iobsi(jo,1) = surfdata%mi(jo) 
     457            fbdata%iobsj(jo,1) = surfdata%mj(jo) 
    379458         ELSE 
    380             fbdata%iobsi(jo,1) = mig(sladata%mi(jo)) 
    381             fbdata%iobsj(jo,1) = mjg(sladata%mj(jo)) 
     459            fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 
     460            fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 
    382461         ENDIF 
    383462         CALL greg2jul( 0, & 
    384             &           sladata%nmin(jo), & 
    385             &           sladata%nhou(jo), & 
    386             &           sladata%nday(jo), & 
    387             &           sladata%nmon(jo), & 
    388             &           sladata%nyea(jo), & 
     463            &           surfdata%nmin(jo), & 
     464            &           surfdata%nhou(jo), & 
     465            &           surfdata%nday(jo), & 
     466            &           surfdata%nmon(jo), & 
     467            &           surfdata%nyea(jo), & 
    389468            &           fbdata%ptim(jo),   & 
    390469            &           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)  
     470         fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 
     471         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 
     472         fbdata%pob(1,jo,1)    = surfdata%robs(jo,1)  
    394473         fbdata%pdep(1,jo)     = 0.0 
    395474         fbdata%idqc(1,jo)     = 0 
    396475         fbdata%idqcf(:,1,jo)  = 0 
    397          IF ( sladata%nqc(jo) > 10 ) THEN 
     476         IF ( surfdata%nqc(jo) > 10 ) THEN 
    398477            fbdata%ivqc(jo,1)       = 4 
    399478            fbdata%ivlqc(1,jo,1)    = 4 
    400479            fbdata%ivlqcf(1,1,jo,1) = 0 
    401             fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10 
     480            fbdata%ivlqcf(2,1,jo,1) = surfdata%nqc(jo) - 10 
    402481         ELSE 
    403             fbdata%ivqc(jo,1)       = sladata%nqc(jo) 
    404             fbdata%ivlqc(1,jo,1)    = sladata%nqc(jo) 
     482            fbdata%ivqc(jo,1)       = surfdata%nqc(jo) 
     483            fbdata%ivlqc(1,jo,1)    = surfdata%nqc(jo) 
    405484            fbdata%ivlqcf(:,1,jo,1) = 0 
    406485         ENDIF 
    407486         fbdata%iobsk(1,jo,1)  = 0 
    408          fbdata%pext(1,jo,1) = sladata%rext(jo,2) 
    409          DO ja = 1, nadd 
     487         IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 
     488         DO ja = 1, iadd 
    410489            fbdata%padd(1,jo,2+ja,1) = & 
    411                & sladata%rext(jo,padd%ipoint(ja)) 
    412          END DO 
    413          DO je = 1, next 
     490               & surfdata%rext(jo,padd%ipoint(ja)) 
     491         END DO 
     492         DO je = 1, iext 
    414493            fbdata%pext(1,jo,1+je) = & 
    415                & sladata%rext(jo,pext%ipoint(je)) 
     494               & surfdata%rext(jo,pext%ipoint(je)) 
    416495         END DO 
    417496      END DO 
    418497 
    419498      ! Write the obfbdata structure 
    420       CALL write_obfbdata( cfname, fbdata ) 
     499      CALL write_obfbdata( clfname, fbdata ) 
    421500 
    422501      ! Output some basic statistics 
    … …  
    425504      CALL dealloc_obfbdata( fbdata ) 
    426505 
    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 
     506   END SUBROUTINE obs_wri_surf 
    931507 
    932508   SUBROUTINE obs_wri_stats( fbdata ) 
    … …  
    951527      INTEGER :: jo 
    952528      INTEGER :: jk 
    953  
    954 !      INTEGER :: nlev 
    955 !      INTEGER :: nlevmpp 
    956 !      INTEGER :: nobsmpp 
    957       INTEGER :: numgoodobs 
    958       INTEGER :: numgoodobsmpp 
     529      INTEGER :: inumgoodobs 
     530      INTEGER :: inumgoodobsmpp 
    959531      REAL(wp) :: zsumx 
    960532      REAL(wp) :: zsumx2 
    961533      REAL(wp) :: zomb 
     534       
    962535 
    963536      IF (lwp) THEN 
    964537         WRITE(numout,*) '' 
    965538         WRITE(numout,*) 'obs_wri_stats :' 
    966          WRITE(numout,*) '~~~~~~~~~~~~~~~'  
     539         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    967540      ENDIF 
    968541 
    … …  
    970543         zsumx=0.0_wp 
    971544         zsumx2=0.0_wp 
    972          numgoodobs=0 
     545         inumgoodobs=0 
    973546         DO jo = 1, fbdata%nobs 
    974547            DO jk = 1, fbdata%nlev 
    … …  
    976549                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 
    977550                  & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 
    978         
    979              zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 
     551 
     552                  zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 
    980553                  zsumx=zsumx+zomb 
    981554                  zsumx2=zsumx2+zomb**2 
    982                   numgoodobs=numgoodobs+1 
    983           ENDIF 
     555                  inumgoodobs=inumgoodobs+1 
     556               ENDIF 
    984557            ENDDO 
    985558         ENDDO 
    986559 
    987          CALL obs_mpp_sum_integer( numgoodobs, numgoodobsmpp ) 
     560         CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 
    988561         CALL mpp_sum(zsumx) 
    989562         CALL mpp_sum(zsumx2) 
    990563 
    991564         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,*) '' 
     565            WRITE(numout,*) 'Type: ',fbdata%cname(jvar),'  Total number of good observations: ',inumgoodobsmpp  
     566            WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 
     567            WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 
     568            WRITE(numout,*) '' 
    996569         ENDIF 
    997   
     570 
    998571      ENDDO 
    999572 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r6060 r6069  
    4444   LOGICAL , PUBLIC ::   ln_dm2dc       !: Daily mean to Diurnal Cycle short wave (qsr) 
    4545   LOGICAL , PUBLIC ::   ln_rnf         !: runoffs / runoff mouths 
     46   LOGICAL , PUBLIC ::   ln_isf         !: ice shelf melting 
    4647   LOGICAL , PUBLIC ::   ln_ssr         !: Sea Surface restoring on SST and/or SSS       
    4748   LOGICAL , PUBLIC ::   ln_apr_dyn     !: Atmospheric pressure forcing used on dynamics (ocean & ice) 
    4849   INTEGER , PUBLIC ::   nn_ice         !: flag for ice in the surface boundary condition (=0/1/2/3) 
    49    INTEGER , PUBLIC ::   nn_isf         !: flag for isf in the surface boundary condition (=0/1/2/3/4)  
    5050   INTEGER , PUBLIC ::   nn_ice_embd    !: flag for levitating/embedding sea-ice in the ocean 
    5151   !                                             !: =0 levitating ice (no mass exchange, concentration/dilution effect) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r6060 r6069  
    3535   ! public in order to be able to output then  
    3636 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc   
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf              !: net heat flux from ice shelf 
     37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   risf_tsc_b, risf_tsc  !: before and now T & S isf contents [K.m/s & PSU.m/s]  
     38   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qisf                  !: net heat flux from ice shelf      [W/m2] 
    3939   REAL(wp), PUBLIC ::   rn_hisf_tbl                 !: thickness of top boundary layer [m] 
    40    LOGICAL , PUBLIC ::   ln_divisf                   !: flag to correct divergence  
    41    INTEGER , PUBLIC ::   nn_isfblk                   !:  
    42    INTEGER , PUBLIC ::   nn_gammablk                 !: 
    43    LOGICAL , PUBLIC ::   ln_conserve                 !: 
    44    REAL(wp), PUBLIC ::   rn_gammat0                  !: temperature exchange coeficient 
    45    REAL(wp), PUBLIC ::   rn_gammas0                  !: salinity    exchange coeficient  
    46    REAL(wp), PUBLIC ::   rdivisf                     !: flag to test if fwf apply on divergence 
     40   INTEGER , PUBLIC ::   nn_isf                      !: flag to choose between explicit/param/specified   
     41   INTEGER , PUBLIC ::   nn_isfblk                   !: flag to choose the bulk formulation to compute the ice shelf melting 
     42   INTEGER , PUBLIC ::   nn_gammablk                 !: flag to choose how the exchange coefficient is computed 
     43   REAL(wp), PUBLIC ::   rn_gammat0                  !: temperature exchange coeficient [] 
     44   REAL(wp), PUBLIC ::   rn_gammas0                  !: salinity    exchange coeficient [] 
    4745 
    4846   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rzisf_tbl              !:depth of calving front (shallowest point) nn_isf ==2/3 
    49    REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rhisf_tbl, rhisf_tbl_0 !:thickness of tbl 
     47   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  rhisf_tbl, rhisf_tbl_0 !:thickness of tbl  [m] 
    5048   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  r1_hisf_tbl            !:1/thickness of tbl 
    5149   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ralpha                 !:proportion of bottom cell influenced by tbl  
    5250   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5351   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    54    INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    55  
    56    REAL(wp), PUBLIC, SAVE ::   rcpi   = 2000.0_wp     ! phycst ? 
    57    REAL(wp), PUBLIC, SAVE ::   kappa  = 1.54e-6_wp    ! phycst ? 
    58    REAL(wp), PUBLIC, SAVE ::   rhoisf = 920.0_wp      ! phycst ? 
    59    REAL(wp), PUBLIC, SAVE ::   tsurf  = -20.0_wp      ! phycst ? 
    60    REAL(wp), PUBLIC, SAVE ::   lfusisf= 0.334e6_wp    ! phycst ? 
     52   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)      ::  misfkt, misfkb         !:Level of ice shelf base 
     53 
     54   REAL(wp), PUBLIC, SAVE ::   rcpi     = 2000.0_wp     ! specific heat of ice shelf             [J/kg/K] 
     55   REAL(wp), PUBLIC, SAVE ::   rkappa   = 1.54e-6_wp    ! heat diffusivity through the ice-shelf [m2/s] 
     56   REAL(wp), PUBLIC, SAVE ::   rhoisf   = 920.0_wp      ! volumic mass of ice shelf              [kg/m3] 
     57   REAL(wp), PUBLIC, SAVE ::   tsurf    = -20.0_wp      ! air temperature on top of ice shelf    [C] 
     58   REAL(wp), PUBLIC, SAVE ::   rlfusisf = 0.334e6_wp    ! latent heat of fusion of ice shelf     [J/kg] 
    6159 
    6260!: Variable used in fldread to read the forcing file (nn_isf == 4 .OR. nn_isf == 3) 
    63    CHARACTER(len=100), PUBLIC ::   cn_dirisf  = './'    !: Root directory for location of ssr files 
    64    TYPE(FLD_N)       , PUBLIC ::   sn_qisf, sn_fwfisf     !: information about the runoff file to be read 
    65    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qisf, sf_fwfisf 
    66    TYPE(FLD_N)       , PUBLIC ::   sn_rnfisf              !: information about the runoff file to be read 
    67    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_rnfisf            
    68    TYPE(FLD_N)       , PUBLIC ::   sn_depmax_isf, sn_depmin_isf, sn_Leff_isf     !: information about the runoff file to be read 
     61   CHARACTER(len=100), PUBLIC           :: cn_dirisf  = './' !: Root directory for location of ssr files 
     62   TYPE(FLD_N)       , PUBLIC           :: sn_fwfisf         !: information about the isf melting file to be read 
     63   TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_fwfisf 
     64   TYPE(FLD_N)       , PUBLIC           :: sn_rnfisf         !: information about the isf melting param.   file to be read 
     65   TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnfisf            
     66   TYPE(FLD_N)       , PUBLIC           :: sn_depmax_isf     !: information about the grounding line depth file to be read 
     67   TYPE(FLD_N)       , PUBLIC           :: sn_depmin_isf     !: information about the calving   line depth file to be read 
     68   TYPE(FLD_N)       , PUBLIC           :: sn_Leff_isf       !: information about the effective length     file to be read 
    6969    
    7070   !!---------------------------------------------------------------------- 
    … …  
    7575CONTAINS 
    7676  
    77    SUBROUTINE sbc_isf(kt) 
     77  SUBROUTINE sbc_isf(kt) 
    7878      !!--------------------------------------------------------------------- 
    79       !!                     ***  ROUTINE sbc_isf  *** 
    80       !!--------------------------------------------------------------------- 
    81       INTEGER, INTENT(in)          ::   kt         ! ocean time step 
    82       ! 
    83       INTEGER                      ::   ji, jj, jk, ijkmin, inum, ierror 
    84       INTEGER                      ::   ikt, ikb   ! top and bottom level of the isf boundary layer 
    85       REAL(wp)                     ::   rmin 
    86       REAL(wp)                     ::   zhk 
    87       REAL(wp)                     ::   zt_frz, zpress 
    88       CHARACTER(len=256)           ::   cfisf , cvarzisf, cvarhisf   ! name for isf file 
    89       CHARACTER(LEN=256)           :: cnameis                     ! name of iceshelf file 
    90       CHARACTER (LEN=32)           :: cvarLeff                    ! variable name for efficient Length scale 
    91       INTEGER           ::   ios           ! Local integer output status for namelist read 
    92       !! 
    93       NAMELIST/namsbc_isf/ nn_isfblk, rn_hisf_tbl, ln_divisf, ln_conserve, rn_gammat0, rn_gammas0, nn_gammablk, & 
    94          &                 sn_fwfisf, sn_qisf, sn_rnfisf, sn_depmax_isf, sn_depmin_isf, sn_Leff_isf 
     79      !!                  ***  ROUTINE sbc_isf  *** 
     80      !! 
     81      !! ** Purpose : Compute Salt and Heat fluxes related to ice_shelf  
     82      !!              melting and freezing  
     83      !! 
     84      !! ** Method  :  4 parameterizations are available according to nn_isf  
     85      !!               nn_isf = 1 : Realistic ice_shelf formulation 
     86      !!                        2 : Beckmann & Goose parameterization 
     87      !!                        3 : Specified runoff in deptht (Mathiot & al. ) 
     88      !!                        4 : specified fwf and heat flux forcing beneath the ice shelf 
     89      !!---------------------------------------------------------------------- 
     90      INTEGER, INTENT( in ) :: kt                   ! ocean time step 
     91      ! 
     92      INTEGER               :: ji, jj               ! loop index 
     93      REAL(wp), DIMENSION (:,:), POINTER :: zt_frz, zdep ! freezing temperature (zt_frz) at depth (zdep)  
    9594      !!--------------------------------------------------------------------- 
    9695      ! 
    … …  
    9897      IF( kt == nit000 ) THEN                   !  First call kt=nit000  ! 
    9998         !                                      ! ====================== ! 
    100          REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
    101          READ  ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) 
    102 901      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in reference namelist', lwp ) 
    103  
    104          REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs 
    105          READ  ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 ) 
    106 902      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist', lwp ) 
    107          IF(lwm) WRITE ( numond, namsbc_isf ) 
    108  
    109          IF ( lwp ) WRITE(numout,*) 
    110          IF ( lwp ) WRITE(numout,*) 'sbc_isf: heat flux of the ice shelf' 
    111          IF ( lwp ) WRITE(numout,*) '~~~~~~~~~' 
    112          IF ( lwp ) WRITE(numout,*) 'sbcisf :'  
    113          IF ( lwp ) WRITE(numout,*) '~~~~~~~~' 
    114          IF ( lwp ) WRITE(numout,*) '        nn_isf      = ', nn_isf 
    115          IF ( lwp ) WRITE(numout,*) '        nn_isfblk   = ', nn_isfblk 
    116          IF ( lwp ) WRITE(numout,*) '        rn_hisf_tbl = ', rn_hisf_tbl 
    117          IF ( lwp ) WRITE(numout,*) '        ln_divisf   = ', ln_divisf  
    118          IF ( lwp ) WRITE(numout,*) '        nn_gammablk = ', nn_gammablk  
    119          IF ( lwp ) WRITE(numout,*) '        rn_tfri2    = ', rn_tfri2  
    120          IF (ln_divisf) THEN       ! keep it in the namelist ??? used true anyway as for runoff ? (PM) 
    121             rdivisf = 1._wp 
    122          ELSE 
    123             rdivisf = 0._wp 
    124          END IF 
    125          ! 
    126          ! Allocate public variable 
    127          IF ( sbc_isf_alloc()  /= 0 )         CALL ctl_stop( 'STOP', 'sbc_isf : unable to allocate arrays' ) 
    128          ! 
    129          ! initialisation 
    130          qisf(:,:)        = 0._wp  ; fwfisf(:,:) = 0._wp 
    131          risf_tsc(:,:,:)  = 0._wp 
    132          ! 
    133          ! define isf tbl tickness, top and bottom indice 
    134          IF      (nn_isf == 1) THEN 
    135             rhisf_tbl(:,:) = rn_hisf_tbl 
    136             misfkt(:,:)    = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv 
    137          ELSE IF ((nn_isf == 3) .OR. (nn_isf == 2)) THEN 
    138             ALLOCATE( sf_rnfisf(1), STAT=ierror ) 
    139             ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) 
    140             CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
    141  
    142             !: read effective lenght (BG03) 
    143             IF (nn_isf == 2) THEN 
    144                ! Read Data and save some integral values 
    145                CALL iom_open( sn_Leff_isf%clname, inum ) 
    146                cvarLeff  = 'soLeff'               !: variable name for Efficient Length scale 
    147                CALL iom_get( inum, jpdom_data, cvarLeff, risfLeff , 1) 
    148                CALL iom_close(inum) 
    149                ! 
    150                risfLeff = risfLeff*1000           !: convertion in m 
    151             END IF 
    152  
    153            ! read depth of the top and bottom of the isf top boundary layer (in this case, isf front depth and grounding line depth) 
    154             CALL iom_open( sn_depmax_isf%clname, inum ) 
    155             cvarhisf = TRIM(sn_depmax_isf%clvar) 
    156             CALL iom_get( inum, jpdom_data, cvarhisf, rhisf_tbl, 1) !: depth of deepest point of the ice shelf base 
    157             CALL iom_close(inum) 
    158             ! 
    159             CALL iom_open( sn_depmin_isf%clname, inum ) 
    160             cvarzisf = TRIM(sn_depmin_isf%clvar) 
    161             CALL iom_get( inum, jpdom_data, cvarzisf, rzisf_tbl, 1) !: depth of shallowest point of the ice shelves base 
    162             CALL iom_close(inum) 
    163             ! 
    164             rhisf_tbl(:,:) = rhisf_tbl(:,:) - rzisf_tbl(:,:)        !: tickness isf boundary layer 
    165  
    166            !! compute first level of the top boundary layer 
    167            DO ji = 1, jpi 
    168               DO jj = 1, jpj 
    169                   jk = 2 
    170                   DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_n(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    171                   misfkt(ji,jj) = jk-1 
    172                END DO 
    173             END DO 
    174  
    175          ELSE IF ( nn_isf == 4 ) THEN 
    176             ! as in nn_isf == 1 
    177             rhisf_tbl(:,:) = rn_hisf_tbl 
    178             misfkt(:,:)    = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv 
    179              
    180             ! load variable used in fldread (use for temporal interpolation of isf fwf forcing) 
    181             ALLOCATE( sf_fwfisf(1), sf_qisf(1), STAT=ierror ) 
    182             ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) 
    183             ALLOCATE( sf_qisf(1)%fnow(jpi,jpj,1), sf_qisf(1)%fdta(jpi,jpj,1,2) ) 
    184             CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
    185             !CALL fld_fill( sf_qisf  , (/ sn_qisf   /), cn_dirisf, 'sbc_isf_init', 'read heat flux isf data'       , 'namsbc_isf' ) 
    186          END IF 
    187           
    188          ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    189          rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
    190          DO jj = 1,jpj 
    191             DO ji = 1,jpi 
    192                ikt = misfkt(ji,jj) 
    193                ikb = misfkt(ji,jj) 
    194                ! thickness of boundary layer at least the top level thickness 
    195                rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3t_n(ji,jj,ikt)) 
    196  
    197                ! determine the deepest level influenced by the boundary layer 
    198                ! test on tmask useless ????? 
    199                DO jk = ikt, mbkt(ji,jj) 
    200                   IF ( (SUM(e3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    201                END DO 
    202                rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(e3t_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
    203                misfkb(ji,jj) = ikb                                                  ! last wet level of the tbl 
    204                r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 
    205  
    206                zhk           = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)  ! proportion of tbl cover by cell from ikt to ikb - 1 
    207                ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / e3t_n(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer 
    208             END DO 
    209          END DO 
     99         CALL sbc_isf_init 
     100      !                                         ! ---------------------------------------- ! 
     101      ELSE                                      !          Swap of forcing fields          ! 
     102         !                                      ! ---------------------------------------- ! 
     103         fwfisf_b  (:,:  ) = fwfisf  (:,:  )    ! Swap the ocean forcing fields except at nit000 
     104         risf_tsc_b(:,:,:) = risf_tsc(:,:,:)    ! where before fields are set at the end of the routine 
    210105         ! 
    211106      END IF 
    212107 
    213       !                                            ! ---------------------------------------- ! 
    214       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    215          !                                         ! ---------------------------------------- ! 
    216          fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
    217          risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    218          ! 
    219       ENDIF 
    220  
    221108      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    222  
    223  
    224          ! compute salf and heat flux 
    225          IF (nn_isf == 1) THEN 
    226             ! realistic ice shelf formulation 
     109         ! allocation 
     110         CALL wrk_alloc( jpi,jpj, zt_frz, zdep  ) 
     111 
     112         ! compute salt and heat flux 
     113         SELECT CASE ( nn_isf ) 
     114         CASE ( 1 )    ! realistic ice shelf formulation 
    227115            ! compute T/S/U/V for the top boundary layer 
    228116            CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T') 
    229117            CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T') 
    230             CALL sbc_isf_tbl(un(:,:,:),utbl(:,:),'U') 
    231             CALL sbc_isf_tbl(vn(:,:,:),vtbl(:,:),'V') 
     118            CALL sbc_isf_tbl(un(:,:,:)        ,utbl(:,:),'U') 
     119            CALL sbc_isf_tbl(vn(:,:,:)        ,vtbl(:,:),'V') 
    232120            ! iom print 
    233121            CALL iom_put('ttbl',ttbl(:,:)) 
    234122            CALL iom_put('stbl',stbl(:,:)) 
    235             CALL iom_put('utbl',utbl(:,:)) 
    236             CALL iom_put('vtbl',vtbl(:,:)) 
     123            CALL iom_put('utbl',utbl(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)) 
     124            CALL iom_put('vtbl',vtbl(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)) 
    237125            ! compute fwf and heat flux 
    238126            CALL sbc_isf_cav (kt) 
    239127 
    240          ELSE IF (nn_isf == 2) THEN 
    241             ! Beckmann and Goosse parametrisation  
     128         CASE ( 2 )    ! Beckmann and Goosse parametrisation  
    242129            stbl(:,:)   = soce 
    243130            CALL sbc_isf_bg03(kt) 
    244131 
    245          ELSE IF (nn_isf == 3) THEN 
    246             ! specified runoff in depth (Mathiot et al., XXXX in preparation) 
     132         CASE ( 3 )    ! specified runoff in depth (Mathiot et al., XXXX in preparation) 
    247133            CALL fld_read ( kt, nn_fsbc, sf_rnfisf   ) 
    248             fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1)         ! fresh water flux from the isf (fwfisf <0 mean melting)  
    249             qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
     134            fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1)         ! fwf flux from the isf (fwfisf <0 mean melting)  
     135            qisf(:,:)   = fwfisf(:,:) * rlfusisf             ! heat flux 
    250136            stbl(:,:)   = soce 
    251137 
    252          ELSE IF (nn_isf == 4) THEN 
    253             ! specified fwf and heat flux forcing beneath the ice shelf 
     138         CASE ( 4 )    ! specified fwf and heat flux forcing beneath the ice shelf 
    254139            CALL fld_read ( kt, nn_fsbc, sf_fwfisf   ) 
    255             !CALL fld_read ( kt, nn_fsbc, sf_qisf   ) 
    256             fwfisf(:,:) = sf_fwfisf(1)%fnow(:,:,1)            ! fwf 
    257             qisf(:,:)   = fwfisf(:,:) * lfusisf              ! heat        flux 
    258             !qisf(:,:)   = sf_qisf(1)%fnow(:,:,1)              ! heat flux 
     140            fwfisf(:,:) = - sf_fwfisf(1)%fnow(:,:,1)           ! fwf  flux from the isf (fwfisf <0 mean melting) 
     141            qisf(:,:)   = fwfisf(:,:) * rlfusisf               ! heat flux 
    259142            stbl(:,:)   = soce 
    260143 
    261          END IF 
     144         END SELECT 
     145 
    262146         ! compute tsc due to isf 
    263          ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
    264 !         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    265          zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    266          risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
     147         ! isf melting implemented as a volume flux and we assume that melt water is at 0 PSU. 
     148         ! WARNING water add at temp = 0C, need to add a correction term (fwfisf * tfreez / rau0). 
     149         ! compute freezing point beneath ice shelf (or top cell if nn_isf = 3) 
     150         DO jj = 1,jpj 
     151            DO ji = 1,jpi 
     152               zdep(ji,jj)=fsdepw_n(ji,jj,misfkt(ji,jj)) 
     153            END DO 
     154         END DO 
     155         CALL eos_fzp( stbl(:,:), zt_frz(:,:), zdep(:,:) ) 
    267156          
    268          ! salt effect already take into account in vertical advection 
    269          risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    270  
    271          ! output 
    272          IF( iom_use('qisf'  ) )   CALL iom_put('qisf'  , qisf) 
    273          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    274  
    275          ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
    276          fwfisf(:,:) = rdivisf * fwfisf(:,:)          
    277   
     157         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - fwfisf(:,:) * zt_frz(:,:) * r1_rau0 ! 
     158         risf_tsc(:,:,jp_sal) = 0.0_wp 
     159 
    278160         ! lbclnk 
    279161         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    280162         CALL lbc_lnk(risf_tsc(:,:,jp_sal),'T',1.) 
    281          CALL lbc_lnk(fwfisf(:,:)   ,'T',1.) 
    282          CALL lbc_lnk(qisf(:,:)     ,'T',1.) 
    283  
    284          IF( kt == nit000 ) THEN                          !   set the forcing field at nit000 - 1    ! 
     163         CALL lbc_lnk(fwfisf(:,:)         ,'T',1.) 
     164         CALL lbc_lnk(qisf(:,:)           ,'T',1.) 
     165 
     166         IF( kt == nit000 ) THEN                         !   set the forcing field at nit000 - 1    ! 
    285167            IF( ln_rstart .AND.    &                     ! Restart: read in restart file 
    286168                 & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN 
    … …  
    293175               risf_tsc_b(:,:,:)= risf_tsc(:,:,:) 
    294176            END IF 
    295          ENDIF 
     177         END IF 
    296178         !  
     179         ! output 
     180         CALL iom_put('qisf'  , qisf) 
     181         CALL iom_put('fwfisf', fwfisf) 
     182 
     183         ! deallocation 
     184         CALL wrk_dealloc( jpi,jpj, zt_frz, zdep  ) 
    297185      END IF 
    298186      !   
    … …  
    313201               &    STAT= sbc_isf_alloc ) 
    314202         ! 
    315          IF( lk_mpp                  )   CALL mpp_sum ( sbc_isf_alloc ) 
     203         IF( lk_mpp             )   CALL mpp_sum ( sbc_isf_alloc ) 
    316204         IF( sbc_isf_alloc /= 0 )   CALL ctl_warn('sbc_isf_alloc: failed to allocate arrays.') 
    317205         ! 
    318       ENDIF 
     206      END IF 
    319207  END FUNCTION 
    320208 
    321  
    322    SUBROUTINE sbc_isf_bg03(kt) 
    323       !!========================================================================== 
    324       !!                 *** SUBROUTINE sbcisf_bg03  *** 
    325       !! add net heat and fresh water flux from ice shelf melting 
    326       !! into the adjacent ocean using the parameterisation by 
    327       !! Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean 
    328       !!     interaction for climate models", Ocean Modelling 5(2003) 157-170. 
    329       !!  (hereafter BG) 
    330       !!========================================================================== 
    331       !!---------------------------------------------------------------------- 
    332       !!   sbc_isf_bg03      : routine called from sbcmod 
    333       !!---------------------------------------------------------------------- 
    334       !! 
    335       !! ** Purpose   :   Add heat and fresh water fluxes due to ice shelf melting 
    336       !! ** Reference :   Beckmann et Goosse, 2003, Ocean Modelling 
    337       !! 
     209  SUBROUTINE sbc_isf_init 
     210      !!--------------------------------------------------------------------- 
     211      !!                  ***  ROUTINE sbc_isf_init  *** 
     212      !! 
     213      !! ** Purpose : Initialisation of variables for iceshelf fluxes formulation 
     214      !! 
     215      !! ** Method  :  4 parameterizations are available according to nn_isf  
     216      !!               nn_isf = 1 : Realistic ice_shelf formulation 
     217      !!                        2 : Beckmann & Goose parameterization 
     218      !!                        3 : Specified runoff in deptht (Mathiot & al. ) 
     219      !!                        4 : specified fwf and heat flux forcing beneath the ice shelf 
     220      !!---------------------------------------------------------------------- 
     221      INTEGER               :: ji, jj, jk           ! loop index 
     222      INTEGER               :: ik                   ! current level index 
     223      INTEGER               :: ikt, ikb             ! top and bottom level of the isf boundary layer 
     224      INTEGER               :: inum, ierror 
     225      INTEGER               :: ios                  ! Local integer output status for namelist read 
     226      REAL(wp)              :: zhk 
     227      CHARACTER(len=256)    :: cvarzisf, cvarhisf   ! name for isf file 
     228      CHARACTER(LEN=32 )    :: cvarLeff             ! variable name for efficient Length scale 
     229      !!---------------------------------------------------------------------- 
     230      NAMELIST/namsbc_isf/ nn_isfblk, rn_hisf_tbl, rn_gammat0, rn_gammas0, nn_gammablk, nn_isf, & 
     231                         & sn_fwfisf, sn_rnfisf, sn_depmax_isf, sn_depmin_isf, sn_Leff_isf 
     232      !!---------------------------------------------------------------------- 
     233 
     234      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
     235      READ  ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) 
     236901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in reference namelist', lwp ) 
     237 
     238      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs 
     239      READ  ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 ) 
     240902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist', lwp ) 
     241      IF(lwm) WRITE ( numond, namsbc_isf ) 
     242 
     243      IF ( lwp ) WRITE(numout,*) 
     244      IF ( lwp ) WRITE(numout,*) 'sbc_isf: heat flux of the ice shelf' 
     245      IF ( lwp ) WRITE(numout,*) '~~~~~~~~~' 
     246      IF ( lwp ) WRITE(numout,*) 'sbcisf :'  
     247      IF ( lwp ) WRITE(numout,*) '~~~~~~~~' 
     248      IF ( lwp ) WRITE(numout,*) '        nn_isf      = ', nn_isf 
     249      IF ( lwp ) WRITE(numout,*) '        nn_isfblk   = ', nn_isfblk 
     250      IF ( lwp ) WRITE(numout,*) '        rn_hisf_tbl = ', rn_hisf_tbl 
     251      IF ( lwp ) WRITE(numout,*) '        nn_gammablk = ', nn_gammablk  
     252      IF ( lwp ) WRITE(numout,*) '        rn_gammat0  = ', rn_gammat0   
     253      IF ( lwp ) WRITE(numout,*) '        rn_gammas0  = ', rn_gammas0   
     254      IF ( lwp ) WRITE(numout,*) '        rn_tfri2    = ', rn_tfri2  
     255      ! 
     256      ! Allocate public variable 
     257      IF ( sbc_isf_alloc()  /= 0 )         CALL ctl_stop( 'STOP', 'sbc_isf : unable to allocate arrays' ) 
     258      ! 
     259      ! initialisation 
     260      qisf(:,:)        = 0._wp  ; fwfisf  (:,:) = 0._wp 
     261      risf_tsc(:,:,:)  = 0._wp  ; fwfisf_b(:,:) = 0._wp 
     262      ! 
     263      ! define isf tbl tickness, top and bottom indice 
     264      SELECT CASE ( nn_isf ) 
     265      CASE ( 1 )  
     266         rhisf_tbl(:,:) = rn_hisf_tbl 
     267         misfkt(:,:)    = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv 
     268 
     269      CASE ( 2 , 3 ) 
     270         ALLOCATE( sf_rnfisf(1), STAT=ierror ) 
     271         ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) 
     272         CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
     273 
     274         !  read effective lenght (BG03) 
     275         IF (nn_isf == 2) THEN 
     276            CALL iom_open( sn_Leff_isf%clname, inum ) 
     277            cvarLeff = TRIM(sn_Leff_isf%clvar) 
     278            CALL iom_get( inum, jpdom_data, cvarLeff, risfLeff , 1) 
     279            CALL iom_close(inum) 
     280            ! 
     281            risfLeff = risfLeff*1000.0_wp           !: convertion in m 
     282         END IF 
     283 
     284         ! read depth of the top and bottom of the isf top boundary layer (in this case, isf front depth and grounding line depth) 
     285         CALL iom_open( sn_depmax_isf%clname, inum ) 
     286         cvarhisf = TRIM(sn_depmax_isf%clvar) 
     287         CALL iom_get( inum, jpdom_data, cvarhisf, rhisf_tbl, 1) !: depth of deepest point of the ice shelf base 
     288         CALL iom_close(inum) 
     289         ! 
     290         CALL iom_open( sn_depmin_isf%clname, inum ) 
     291         cvarzisf = TRIM(sn_depmin_isf%clvar) 
     292         CALL iom_get( inum, jpdom_data, cvarzisf, rzisf_tbl, 1) !: depth of shallowest point of the ice shelves base 
     293         CALL iom_close(inum) 
     294         ! 
     295         rhisf_tbl(:,:) = rhisf_tbl(:,:) - rzisf_tbl(:,:)        !: tickness isf boundary layer 
     296 
     297         !! compute first level of the top boundary layer 
     298         DO ji = 1, jpi 
     299            DO jj = 1, jpj 
     300                ik = 2 
     301                DO WHILE ( ik <= mbkt(ji,jj) .AND. fsdepw(ji,jj,ik) < rzisf_tbl(ji,jj) ) ;  ik = ik + 1 ;  END DO 
     302                misfkt(ji,jj) = ik-1 
     303            END DO 
     304         END DO 
     305 
     306      CASE ( 4 )  
     307         ! as in nn_isf == 1 
     308         rhisf_tbl(:,:) = rn_hisf_tbl 
     309         misfkt(:,:)    = mikt(:,:)         ! same indice for bg03 et cav => used in isfdiv 
     310          
     311         ! load variable used in fldread (use for temporal interpolation of isf fwf forcing) 
     312         ALLOCATE( sf_fwfisf(1), STAT=ierror ) 
     313         ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) 
     314         CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) 
     315 
     316      END SELECT 
     317          
     318      rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
     319 
     320      ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
     321      DO jj = 1,jpj 
     322         DO ji = 1,jpi 
     323            ikt = misfkt(ji,jj) 
     324            ikb = misfkt(ji,jj) 
     325            ! thickness of boundary layer at least the top level thickness 
     326            rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt)) 
     327 
     328            ! determine the deepest level influenced by the boundary layer 
     329            DO jk = ikt+1, mbkt(ji,jj) 
     330               IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) < rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     331            END DO 
     332            rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. 
     333            misfkb(ji,jj) = ikb                                                   ! last wet level of the tbl 
     334            r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 
     335 
     336            zhk           = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) ! proportion of tbl cover by cell from ikt to ikb - 1 
     337            ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer 
     338         END DO 
     339      END DO 
     340 
     341  END SUBROUTINE sbc_isf_init 
     342 
     343  SUBROUTINE sbc_isf_bg03(kt) 
     344      !!--------------------------------------------------------------------- 
     345      !!                  ***  ROUTINE sbc_isf_bg03  *** 
     346      !! 
     347      !! ** Purpose : add net heat and fresh water flux from ice shelf melting 
     348      !!          into the adjacent ocean 
     349      !! 
     350      !! ** Method  :   See reference 
     351      !! 
     352      !! ** Reference : Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean 
     353      !!         interaction for climate models", Ocean Modelling 5(2003) 157-170. 
     354      !!         (hereafter BG) 
    338355      !! History : 
    339       !!      !  06-02  (C. Wang) Original code 
     356      !!         06-02  (C. Wang) Original code 
    340357      !!---------------------------------------------------------------------- 
    341358      INTEGER, INTENT ( in ) :: kt 
    342359      ! 
    343     INTEGER :: ji, jj, jk, jish  !temporary integer 
    344     INTEGER :: ijkmin 
    345     INTEGER :: ii, ij, ik  
    346     INTEGER :: inum 
    347  
    348     REAL(wp) :: zt_sum      ! sum of the temperature between 200m and 600m 
    349     REAL(wp) :: zt_ave      ! averaged temperature between 200m and 600m 
    350     REAL(wp) :: zt_frz      ! freezing point temperature at depth z 
    351     REAL(wp) :: zpress      ! pressure to compute the freezing point in depth 
    352      
    353     !!---------------------------------------------------------------------- 
    354     IF ( nn_timing == 1 ) CALL timing_start('sbc_isf_bg03') 
    355      ! 
    356  
    357     ! This test is false only in the very first time step of a run (JMM ???- Initialy build to skip 1rst year of run ) 
    358     DO ji = 1, jpi 
    359        DO jj = 1, jpj 
    360           ik = misfkt(ji,jj) 
    361           !! Initialize arrays to 0 (each step) 
    362           zt_sum = 0.e0_wp 
    363           IF ( ik .GT. 1 ) THEN 
    364     ! 3. -----------the average temperature between 200m and 600m --------------------- 
    365              DO jk = misfkt(ji,jj),misfkb(ji,jj) 
    366              ! freezing point temperature  at ice shelf base BG eq. 2 (JMM sign pb ??? +7.64e-4 !!!) 
    367              ! after verif with UNESCO, wrong sign in BG eq. 2 
    368              ! Calculate freezing temperature 
    369                 zpress = grav*rau0*gdept_n(ji,jj,ik)*1.e-04  
    370                 CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
    371                 zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * e3t_n(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    372              ENDDO 
    373              zt_ave = zt_sum/rhisf_tbl(ji,jj) ! calcul mean value 
    374      
    375     ! 4. ------------Net heat flux and fresh water flux due to the ice shelf 
    376           ! For those corresponding to zonal boundary     
    377              qisf(ji,jj) = - rau0 * rcp * rn_gammat0 * risfLeff(ji,jj) * e1t(ji,jj) * zt_ave  & 
    378                          & / (e1t(ji,jj) * e2t(ji,jj)) * tmask(ji,jj,ik)  
     360      INTEGER  :: ji, jj, jk ! dummy loop index 
     361      INTEGER  :: ik         ! current level 
     362      REAL(wp) :: zt_sum     ! sum of the temperature between 200m and 600m 
     363      REAL(wp) :: zt_ave     ! averaged temperature between 200m and 600m 
     364      REAL(wp) :: zt_frz     ! freezing point temperature at depth z 
     365      REAL(wp) :: zpress     ! pressure to compute the freezing point in depth 
     366      !!---------------------------------------------------------------------- 
     367 
     368      IF ( nn_timing == 1 ) CALL timing_start('sbc_isf_bg03') 
     369      ! 
     370      DO ji = 1, jpi 
     371         DO jj = 1, jpj 
     372            ik = misfkt(ji,jj) 
     373            !! Initialize arrays to 0 (each step) 
     374            zt_sum = 0.e0_wp 
     375            IF ( ik > 1 ) THEN 
     376               ! 1. -----------the average temperature between 200m and 600m --------------------- 
     377               DO jk = misfkt(ji,jj),misfkb(ji,jj) 
     378                  ! freezing point temperature  at ice shelf base BG eq. 2 (JMM sign pb ??? +7.64e-4 !!!) 
     379                  ! after verif with UNESCO, wrong sign in BG eq. 2 
     380                  ! Calculate freezing temperature 
     381                  CALL eos_fzp(stbl(ji,jj), zt_frz, zpress)  
     382                  zt_sum = zt_sum + (tsn(ji,jj,jk,jp_tem)-zt_frz) * e3t_n(ji,jj,jk) * tmask(ji,jj,jk)  ! sum temp 
     383               END DO 
     384               zt_ave = zt_sum/rhisf_tbl(ji,jj) ! calcul mean value 
     385               ! 2. ------------Net heat flux and fresh water flux due to the ice shelf 
     386               ! For those corresponding to zonal boundary     
     387               qisf(ji,jj) = - rau0 * rcp * rn_gammat0 * risfLeff(ji,jj) * e1t(ji,jj) * zt_ave  & 
     388                           & * r1_e1e2t(ji,jj) * tmask(ji,jj,jk) 
    379389              
    380              fwfisf(ji,jj) = qisf(ji,jj) / lfusisf          !fresh water flux kg/(m2s)                   
    381              fwfisf(ji,jj) = fwfisf(ji,jj) * ( soce / stbl(ji,jj) ) 
    382              !add to salinity trend 
    383           ELSE 
    384              qisf(ji,jj) = 0._wp ; fwfisf(ji,jj) = 0._wp 
    385           END IF 
    386        END DO 
    387     END DO 
    388     ! 
    389     IF( nn_timing == 1 )  CALL timing_stop('sbc_isf_bg03') 
     390               fwfisf(ji,jj) = qisf(ji,jj) / rlfusisf          !fresh water flux kg/(m2s)                   
     391               fwfisf(ji,jj) = fwfisf(ji,jj) * ( soce / stbl(ji,jj) ) 
     392               !add to salinity trend 
     393            ELSE 
     394               qisf(ji,jj) = 0._wp ; fwfisf(ji,jj) = 0._wp 
     395            END IF 
     396         END DO 
     397      END DO 
     398      ! 
     399      IF( nn_timing == 1 )  CALL timing_stop('sbc_isf_bg03') 
    390400      ! 
    391401  END SUBROUTINE sbc_isf_bg03 
    392402 
    393  
    394    SUBROUTINE sbc_isf_cav( kt ) 
     403  SUBROUTINE sbc_isf_cav( kt ) 
    395404      !!--------------------------------------------------------------------- 
    396405      !!                     ***  ROUTINE sbc_isf_cav  *** 
    … …  
    407416      INTEGER, INTENT(in)          ::   kt         ! ocean time step 
    408417      ! 
    409       LOGICAL :: ln_isomip = .true. 
    410       REAL(wp), DIMENSION(:,:), POINTER       ::   zfrz,zpress,zti 
    411       REAL(wp), DIMENSION(:,:), POINTER       ::   zgammat2d, zgammas2d  
    412       !REAL(wp), DIMENSION(:,:), POINTER ::   zqisf, zfwfisf 
     418      INTEGER  ::   ji, jj     ! dummy loop indices 
     419      INTEGER  ::   nit 
    413420      REAL(wp) ::   zlamb1, zlamb2, zlamb3 
    414421      REAL(wp) ::   zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 
    415422      REAL(wp) ::   zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac 
    416       REAL(wp) ::   zfwflx, zhtflx, zhtflx_b 
    417       REAL(wp) ::   zgammat, zgammas 
    418       REAL(wp) ::   zeps   =  -1.e-20_wp        !==   Local constant initialization   ==! 
    419       INTEGER  ::   ji, jj     ! dummy loop indices 
    420       INTEGER  ::   ii0, ii1, ij0, ij1   ! temporary integers 
    421       INTEGER  ::   ierror     ! return error code 
    422       LOGICAL  ::   lit=.TRUE. 
    423       INTEGER  ::   nit 
     423      REAL(wp) ::   zeps = 1.e-20_wp         
     424      REAL(wp) ::   zerr 
     425      REAL(wp), DIMENSION(:,:), POINTER ::   zfrz 
     426      REAL(wp), DIMENSION(:,:), POINTER ::   zgammat, zgammas  
     427      REAL(wp), DIMENSION(:,:), POINTER ::   zfwflx, zhtflx, zhtflx_b 
     428      LOGICAL  ::   lit 
    424429      !!--------------------------------------------------------------------- 
    425       ! 
    426       ! coeficient for linearisation of tfreez 
    427       zlamb1=-0.0575 
    428       zlamb2=0.0901 
    429       zlamb3=-7.61e-04 
     430      ! coeficient for linearisation of potential tfreez 
     431      ! Crude approximation for pressure (but commonly used) 
     432      zlamb1 =-0.0573_wp 
     433      zlamb2 = 0.0832_wp 
     434      zlamb3 =-7.53e-08_wp * grav * rau0 
    430435      IF( nn_timing == 1 )  CALL timing_start('sbc_isf_cav') 
    431436      ! 
    432       CALL wrk_alloc( jpi,jpj, zfrz,zpress,zti, zgammat2d, zgammas2d ) 
    433  
    434       zcfac=0.0_wp  
    435       IF (ln_conserve)  zcfac=1.0_wp 
    436       zpress(:,:)=0.0_wp 
    437       zgammat2d(:,:)=0.0_wp 
    438       zgammas2d(:,:)=0.0_wp 
    439       ! 
    440       ! 
    441       DO jj = 1, jpj 
    442          DO ji = 1, jpi 
    443             ! Crude approximation for pressure (but commonly used) 
    444             ! 1e-04 to convert from Pa to dBar 
    445             zpress(ji,jj)=grav*rau0*gdepw_n(ji,jj,mikt(ji,jj))*1.e-04 
    446             ! 
    447          END DO 
     437      CALL wrk_alloc( jpi,jpj, zfrz  , zgammat, zgammas  ) 
     438      CALL wrk_alloc( jpi,jpj, zfwflx, zhtflx , zhtflx_b ) 
     439 
     440      ! initialisation 
     441      zgammat(:,:) = rn_gammat0 ; zgammas (:,:) = rn_gammas0 
     442      zhtflx (:,:) = 0.0_wp     ; zhtflx_b(:,:) = 0.0_wp     
     443      zfwflx (:,:) = 0.0_wp 
     444 
     445      ! compute ice shelf melting 
     446      nit = 1 ; lit = .TRUE. 
     447      DO WHILE ( lit )    ! maybe just a constant number of iteration as in blk_core is fine 
     448         SELECT CASE ( nn_isfblk ) 
     449         CASE ( 1 )   !  ISOMIP formulation (2 equations) for volume flux (Hunter et al., 2006) 
     450            ! Calculate freezing temperature 
     451            CALL eos_fzp( stbl(:,:), zfrz(:,:), risfdep(:,:) ) 
     452 
     453            ! compute gammat every where (2d) 
     454            CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx) 
     455             
     456            ! compute upward heat flux zhtflx and upward water flux zwflx 
     457            DO jj = 1, jpj 
     458               DO ji = 1, jpi 
     459                  zhtflx(ji,jj) =   zgammat(ji,jj)*rcp*rau0*(ttbl(ji,jj)-zfrz(ji,jj)) 
     460                  zfwflx(ji,jj) = - zhtflx(ji,jj)/rlfusisf 
     461               END DO 
     462            END DO 
     463 
     464            ! Compute heat flux and upward fresh water flux 
     465            qisf  (:,:) = - zhtflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) 
     466            fwfisf(:,:) =   zfwflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) 
     467 
     468         CASE ( 2 )  ! ISOMIP+ formulation (3 equations) for volume flux (Asay-Davis et al., 2015) 
     469            ! compute gammat every where (2d) 
     470            CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx) 
     471 
     472            ! compute upward heat flux zhtflx and upward water flux zwflx 
     473            ! Resolution of a 2d equation from equation 21, 22 and 23 to find Sb (Asay-Davis et al., 2015) 
     474            DO jj = 1, jpj 
     475               DO ji = 1, jpi 
     476                  ! compute coeficient to solve the 2nd order equation 
     477                  zeps1 = rcp*rau0*zgammat(ji,jj) 
     478                  zeps2 = rlfusisf*rau0*zgammas(ji,jj) 
     479                  zeps3 = rhoisf*rcpi*rkappa/MAX(risfdep(ji,jj),zeps) 
     480                  zeps4 = zlamb2+zlamb3*risfdep(ji,jj) 
     481                  zeps6 = zeps4-ttbl(ji,jj) 
     482                  zeps7 = zeps4-tsurf 
     483                  zaqe  = zlamb1 * (zeps1 + zeps3) 
     484                  zaqer = 0.5_wp/MIN(zaqe,-zeps) 
     485                  zbqe  = zeps1*zeps6+zeps3*zeps7-zeps2 
     486                  zcqe  = zeps2*stbl(ji,jj) 
     487                  zdis  = zbqe*zbqe-4.0_wp*zaqe*zcqe                
     488 
     489                  ! Presumably zdis can never be negative because gammas is very small compared to gammat 
     490                  ! compute s freeze 
     491                  zsfrz=(-zbqe-SQRT(zdis))*zaqer 
     492                  IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe+SQRT(zdis))*zaqer 
     493 
     494                  ! compute t freeze (eq. 22) 
     495                  zfrz(ji,jj)=zeps4+zlamb1*zsfrz 
     496   
     497                  ! zfwflx is upward water flux 
     498                  ! zhtflx is upward heat flux (out of ocean) 
     499                  ! compute the upward water and heat flux (eq. 28 and eq. 29) 
     500                  zfwflx(ji,jj) = rau0 * zgammas(ji,jj) * (zsfrz-stbl(ji,jj)) / MAX(zsfrz,zeps) 
     501                  zhtflx(ji,jj) = zgammat(ji,jj) * rau0 * rcp * (ttbl(ji,jj) - zfrz(ji,jj) )  
     502               END DO 
     503            END DO 
     504 
     505            ! compute heat and water flux 
     506            qisf  (:,:) = - zhtflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) 
     507            fwfisf(:,:) =   zfwflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) 
     508 
     509         END SELECT 
     510 
     511         ! define if we need to iterate (nn_gammablk 0/1 do not need iteration) 
     512         IF ( nn_gammablk <  2 ) THEN ; lit = .FALSE. 
     513         ELSE                            
     514            ! check total number of iteration 
     515            IF (nit >= 100) THEN ; CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
     516            ELSE                 ; nit = nit + 1 
     517            END IF 
     518 
     519            ! compute error between 2 iterations 
     520            ! if needed save gammat and compute zhtflx_b for next iteration 
     521            zerr = MAXVAL(ABS(zhtflx-zhtflx_b)) 
     522            IF ( zerr <= 0.01_wp ) THEN ; lit = .FALSE. 
     523            ELSE                        ; zhtflx_b(:,:) = zhtflx(:,:) 
     524            END IF 
     525         END IF 
    448526      END DO 
    449  
    450 ! Calculate in-situ temperature (ref to surface) 
    451       zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    452 ! Calculate freezing temperature 
    453       CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
    454  
    455        
    456       zhtflx=0._wp ; zfwflx=0._wp 
    457       IF (nn_isfblk == 1) THEN 
    458          DO jj = 1, jpj 
    459             DO ji = 1, jpi 
    460                IF (mikt(ji,jj) > 1 ) THEN 
    461                   nit = 1; lit = .TRUE.; zgammat=rn_gammat0; zgammas=rn_gammas0; zhtflx_b=0._wp 
    462                   DO WHILE ( lit ) 
    463 ! compute gamma 
    464                      CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx, ji, jj, lit) 
    465 ! zhtflx is upward heat flux (out of ocean) 
    466                      zhtflx = zgammat*rcp*rau0*(zti(ji,jj)-zfrz(ji,jj)) 
    467 ! zwflx is upward water flux 
    468                      zfwflx = - zhtflx/lfusisf 
    469 ! test convergence and compute gammat 
    470                      IF ( (zhtflx - zhtflx_b) .LE. 0.01 ) lit = .FALSE. 
    471  
    472                      nit = nit + 1 
    473                      IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
    474  
    475 ! save gammat and compute zhtflx_b 
    476                      zgammat2d(ji,jj)=zgammat 
    477                      zhtflx_b = zhtflx 
    478                   END DO 
    479  
    480                   qisf(ji,jj) = - zhtflx 
    481 ! For genuine ISOMIP protocol this should probably be something like 
    482                   fwfisf(ji,jj) = zfwflx  * ( soce / MAX(stbl(ji,jj),zeps)) 
    483                ELSE 
    484                   fwfisf(ji,jj) = 0._wp 
    485                   qisf(ji,jj)   = 0._wp 
    486                END IF 
    487             ! 
    488             END DO 
    489          END DO 
    490  
    491       ELSE IF (nn_isfblk == 2 ) THEN 
    492  
    493 ! More complicated 3 equation thermodynamics as in MITgcm 
    494          DO jj = 2, jpj 
    495             DO ji = 2, jpi 
    496                IF (mikt(ji,jj) > 1 ) THEN 
    497                   nit=1; lit=.TRUE.; zgammat=rn_gammat0; zgammas=rn_gammas0; zhtflx_b=0._wp; zhtflx=0._wp 
    498                   DO WHILE ( lit ) 
    499                      CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx, ji, jj, lit) 
    500  
    501                      zeps1=rcp*rau0*zgammat 
    502                      zeps2=lfusisf*rau0*zgammas 
    503                      zeps3=rhoisf*rcpi*kappa/risfdep(ji,jj) 
    504                      zeps4=zlamb2+zlamb3*risfdep(ji,jj) 
    505                      zeps6=zeps4-zti(ji,jj) 
    506                      zeps7=zeps4-tsurf 
    507                      zaqe=zlamb1 * (zeps1 + zeps3) 
    508                      zaqer=0.5/zaqe 
    509                      zbqe=zeps1*zeps6+zeps3*zeps7-zeps2 
    510                      zcqe=zeps2*stbl(ji,jj) 
    511                      zdis=zbqe*zbqe-4.0*zaqe*zcqe                
    512 ! Presumably zdis can never be negative because gammas is very small compared to gammat 
    513                      zsfrz=(-zbqe-SQRT(zdis))*zaqer 
    514                      IF (zsfrz .lt. 0.0) zsfrz=(-zbqe+SQRT(zdis))*zaqer 
    515                      zfrz(ji,jj)=zeps4+zlamb1*zsfrz 
    516    
    517 ! zfwflx is upward water flux 
    518                      zfwflx= rau0 * zgammas * ( (zsfrz-stbl(ji,jj)) / zsfrz ) 
    519 ! zhtflx is upward heat flux (out of ocean) 
    520 ! If non conservative we have zcfac=0.0 so zhtflx is as ISOMIP but with different zfrz value 
    521                      zhtflx = ( zgammat*rau0 - zcfac*zfwflx ) * rcp * (zti(ji,jj) - zfrz(ji,jj) )  
    522 ! zwflx is upward water flux 
    523 ! If non conservative we have zcfac=0.0 so what follows is then zfwflx*sss_m/zsfrz 
    524                      zfwflx = ( zgammas*rau0 - zcfac*zfwflx ) * (zsfrz - stbl(ji,jj)) / stbl(ji,jj) 
    525 ! test convergence and compute gammat 
    526                      IF (( zhtflx - zhtflx_b) .LE. 0.01 ) lit = .FALSE. 
    527  
    528                      nit = nit + 1 
    529                      IF (nit .GE. 51) THEN 
    530                         WRITE(numout,*) "sbcisf : too many iteration ... ", & 
    531                             &  zhtflx, zhtflx_b, zgammat, zgammas, nn_gammablk, ji, jj, mikt(ji,jj), narea 
    532                         CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
    533                      END IF 
    534 ! save gammat and compute zhtflx_b 
    535                      zgammat2d(ji,jj)=zgammat 
    536                      zgammas2d(ji,jj)=zgammas 
    537                      zhtflx_b = zhtflx 
    538  
    539                   END DO 
    540 ! If non conservative we have zcfac=0.0 so zhtflx is as ISOMIP but with different zfrz value 
    541                   qisf(ji,jj) = - zhtflx  
    542 ! If non conservative we have zcfac=0.0 so what follows is then zfwflx*sss_m/zsfrz 
    543                   fwfisf(ji,jj) = zfwflx  
    544                ELSE 
    545                   fwfisf(ji,jj) = 0._wp 
    546                   qisf(ji,jj)   = 0._wp 
    547                ENDIF 
    548                ! 
    549             END DO 
    550          END DO 
    551       ENDIF 
    552       ! lbclnk 
    553       CALL lbc_lnk(zgammas2d(:,:),'T',1.) 
    554       CALL lbc_lnk(zgammat2d(:,:),'T',1.) 
    555       ! output 
    556       CALL iom_put('isfgammat', zgammat2d) 
    557       CALL iom_put('isfgammas', zgammas2d) 
    558       ! 
    559       CALL wrk_dealloc( jpi,jpj, zfrz,zpress,zti, zgammat2d, zgammas2d ) 
     527      ! 
     528      CALL iom_put('isfgammat', zgammat) 
     529      CALL iom_put('isfgammas', zgammas) 
     530      !  
     531      CALL wrk_dealloc( jpi,jpj, zfrz  , zgammat, zgammas  ) 
     532      CALL wrk_dealloc( jpi,jpj, zfwflx, zhtflx , zhtflx_b ) 
    560533      ! 
    561534      IF( nn_timing == 1 )  CALL timing_stop('sbc_isf_cav') 
    … …  
    563536   END SUBROUTINE sbc_isf_cav 
    564537 
    565  
    566    SUBROUTINE sbc_isf_gammats(gt, gs, zqhisf, zqwisf, ji, jj, lit ) 
     538   SUBROUTINE sbc_isf_gammats(pgt, pgs, pqhisf, pqwisf ) 
    567539      !!---------------------------------------------------------------------- 
    568540      !! ** Purpose    : compute the coefficient echange for heat flux 
    … …  
    573545      !!                Jenkins et al., 2010, JPO, p2298-2312 
    574546      !!--------------------------------------------------------------------- 
    575       REAL(wp), INTENT(inout) :: gt, gs, zqhisf, zqwisf 
    576       INTEGER , INTENT(in)    :: ji,jj 
    577       LOGICAL , INTENT(inout) :: lit 
    578  
    579       INTEGER  :: ikt                 ! loop index 
    580       REAL(wp) :: zut, zvt, zustar           ! U, V at T point and friction velocity 
     547      REAL(wp), DIMENSION(:,:), INTENT(out) :: pgt, pgs 
     548      REAL(wp), DIMENSION(:,:), INTENT(in ) :: pqhisf, pqwisf 
     549      ! 
     550      INTEGER  :: ikt                         
     551      INTEGER  :: ji, jj                     ! loop index 
     552      REAL(wp), DIMENSION(:,:), POINTER :: zustar           ! U, V at T point and friction velocity 
    581553      REAL(wp) :: zdku, zdkv                 ! U, V shear  
    582554      REAL(wp) :: zPr, zSc, zRc              ! Prandtl, Scmidth and Richardson number  
    … …  
    588560      REAL(wp) :: zcoef                      ! temporary coef 
    589561      REAL(wp) :: zdep 
    590       REAL(wp), PARAMETER :: zxsiN = 0.052   ! dimensionless constant 
    591       REAL(wp), PARAMETER :: epsln = 1.0e-20 ! a small positive number 
    592       REAL(wp), PARAMETER :: znu   = 1.95e-6 ! kinamatic viscosity of sea water (m2.s-1) 
    593       REAL(wp) ::   rcs      = 1.0e-3_wp        ! conversion: mm/s ==> m/s 
     562      REAL(wp) :: zeps = 1.0e-20_wp     
     563      REAL(wp), PARAMETER :: zxsiN = 0.052_wp   ! dimensionless constant 
     564      REAL(wp), PARAMETER :: znu   = 1.95e-6_wp ! kinamatic viscosity of sea water (m2.s-1) 
    594565      REAL(wp), DIMENSION(2) :: zts, zab 
    595566      !!--------------------------------------------------------------------- 
    596       ! 
    597       IF( nn_gammablk == 0 ) THEN 
    598       !! gamma is constant (specified in namelist) 
    599          gt = rn_gammat0 
    600          gs = rn_gammas0 
    601          lit = .FALSE. 
    602       ELSE IF ( nn_gammablk == 1 ) THEN 
    603       !! gamma is assume to be proportional to u*  
    604       !! WARNING in case of Losh 2008 tbl parametrization,  
    605       !! you have to used the mean value of u in the boundary layer)  
    606       !! not yet coded 
    607       !! Jenkins et al., 2010, JPO, p2298-2312 
    608          ikt = mikt(ji,jj) 
    609       !! Compute U and V at T points 
    610    !      zut = 0.5 * ( utbl(ji-1,jj  ) + utbl(ji,jj) ) 
    611    !      zvt = 0.5 * ( vtbl(ji  ,jj-1) + vtbl(ji,jj) ) 
    612           zut = utbl(ji,jj) 
    613           zvt = vtbl(ji,jj) 
    614  
    615       !! compute ustar 
    616          zustar = SQRT( rn_tfri2 * (zut * zut + zvt * zvt) ) 
    617       !! Compute mean value over the TBL 
    618  
    619       !! Compute gammats 
    620          gt = zustar * rn_gammat0 
    621          gs = zustar * rn_gammas0 
    622          lit = .FALSE. 
    623       ELSE IF ( nn_gammablk == 2 ) THEN 
    624       !! gamma depends of stability of boundary layer 
    625       !! WARNING in case of Losh 2008 tbl parametrization,  
    626       !! you have to used the mean value of u in the boundary layer)  
    627       !! not yet coded 
    628       !! Holland and Jenkins, 1999, JPO, p1787-1800, eq 14 
    629       !! as MOL depends of flux and flux depends of MOL, best will be iteration (TO DO) 
     567      CALL wrk_alloc( jpi,jpj, zustar ) 
     568      ! 
     569      SELECT CASE ( nn_gammablk ) 
     570      CASE ( 0 ) ! gamma is constant (specified in namelist) 
     571         !! ISOMIP formulation (Hunter et al, 2006) 
     572         pgt(:,:) = rn_gammat0 
     573         pgs(:,:) = rn_gammas0 
     574 
     575      CASE ( 1 ) ! gamma is assume to be proportional to u* 
     576         !! Jenkins et al., 2010, JPO, p2298-2312 
     577         !! Adopted by Asay-Davis et al. (2015) 
     578 
     579         !! compute ustar (eq. 24) 
     580         zustar(:,:) = SQRT( rn_tfri2 * (utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + rn_tfeb2) ) 
     581 
     582         !! Compute gammats 
     583         pgt(:,:) = zustar(:,:) * rn_gammat0 
     584         pgs(:,:) = zustar(:,:) * rn_gammas0 
     585       
     586      CASE ( 2 ) ! gamma depends of stability of boundary layer 
     587         !! Holland and Jenkins, 1999, JPO, p1787-1800, eq 14 
     588         !! as MOL depends of flux and flux depends of MOL, best will be iteration (TO DO) 
     589         !! compute ustar 
     590         zustar(:,:) = SQRT( rn_tfri2 * (utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + rn_tfeb2) ) 
     591 
     592         !! compute Pr and Sc number (can be improved) 
     593         zPr =   13.8_wp 
     594         zSc = 2432.0_wp 
     595 
     596         !! compute gamma mole 
     597         zgmolet = 12.5_wp * zPr ** (2.0/3.0) - 6.0_wp 
     598         zgmoles = 12.5_wp * zSc ** (2.0/3.0) - 6.0_wp 
     599 
     600         !! compute gamma 
     601         DO ji=2,jpi 
     602            DO jj=2,jpj 
    630603               ikt = mikt(ji,jj) 
    631604 
    632       !! Compute U and V at T points 
    633                zut = 0.5 * ( utbl(ji-1,jj  ) + utbl(ji,jj) ) 
    634                zvt = 0.5 * ( vtbl(ji  ,jj-1) + vtbl(ji,jj) ) 
    635  
    636       !! compute ustar 
    637                zustar = SQRT( rn_tfri2 * (zut * zut + zvt * zvt) ) 
    638                IF (zustar == 0._wp) THEN           ! only for kt = 1 I think 
    639                  gt = rn_gammat0 
    640                  gs = rn_gammas0 
     605               IF (zustar(ji,jj) == 0._wp) THEN           ! only for kt = 1 I think 
     606                  pgt = rn_gammat0 
     607                  pgs = rn_gammas0 
    641608               ELSE 
    642       !! compute Rc number (as done in zdfric.F90) 
    643                zcoef = 0.5 / e3w_n(ji,jj,ikt) 
    644                !                                            ! shear of horizontal velocity 
    645                zdku = zcoef * (  un(ji-1,jj  ,ikt  ) + un(ji,jj,ikt  )   & 
    646                   &             -un(ji-1,jj  ,ikt+1) - un(ji,jj,ikt+1)  ) 
    647                zdkv = zcoef * (  vn(ji  ,jj-1,ikt  ) + vn(ji,jj,ikt  )   & 
    648                   &             -vn(ji  ,jj-1,ikt+1) - vn(ji,jj,ikt+1)  ) 
    649                !                                            ! richardson number (minimum value set to zero) 
    650                zRc = rn2(ji,jj,ikt+1) / ( zdku*zdku + zdkv*zdkv + 1.e-20 ) 
    651  
    652       !! compute Pr and Sc number (can be improved) 
    653                zPr =   13.8 
    654                zSc = 2432.0 
    655  
    656       !! compute gamma mole 
    657                zgmolet = 12.5 * zPr ** (2.0/3.0) - 6.0 
    658                zgmoles = 12.5 * zSc ** (2.0/3.0) -6.0 
    659  
    660       !! compute bouyancy  
    661                zts(jp_tem) = ttbl(ji,jj) 
    662                zts(jp_sal) = stbl(ji,jj) 
    663                zdep        = gdepw_n(ji,jj,ikt) 
    664                ! 
    665                CALL eos_rab( zts, zdep, zab ) 
     609                  !! compute Rc number (as done in zdfric.F90) 
     610                  zcoef = 0.5_wp / fse3w(ji,jj,ikt) 
     611                  !                                            ! shear of horizontal velocity 
     612                  zdku = zcoef * (  un(ji-1,jj  ,ikt  ) + un(ji,jj,ikt  )  & 
     613                     &             -un(ji-1,jj  ,ikt+1) - un(ji,jj,ikt+1)  ) 
     614                  zdkv = zcoef * (  vn(ji  ,jj-1,ikt  ) + vn(ji,jj,ikt  )  & 
     615                     &             -vn(ji  ,jj-1,ikt+1) - vn(ji,jj,ikt+1)  ) 
     616                  !                                            ! richardson number (minimum value set to zero) 
     617                  zRc = rn2(ji,jj,ikt+1) / MAX( zdku*zdku + zdkv*zdkv, zeps ) 
     618 
     619                  !! compute bouyancy  
     620                  zts(jp_tem) = ttbl(ji,jj) 
     621                  zts(jp_sal) = stbl(ji,jj) 
     622                  zdep        = fsdepw(ji,jj,ikt) 
    666623                  ! 
    667       !! compute length scale  
    668                zbuofdep = grav * ( zab(jp_tem) * zqhisf - zab(jp_sal) * zqwisf )  !!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     624                  CALL eos_rab( zts, zdep, zab ) 
     625                  ! 
     626                  !! compute length scale  
     627                  zbuofdep = grav * ( zab(jp_tem) * pqhisf(ji,jj) - zab(jp_sal) * pqwisf(ji,jj) )  !!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    669628 
    670629      !! compute Monin Obukov Length 
    671630               ! Maximum boundary layer depth 
    672                zhmax = gdept_n(ji,jj,mbkt(ji,jj)) - gdepw_n(ji,jj,mikt(ji,jj)) -0.001 
     631               zhmax = gdept_n(ji,jj,mbkt(ji,jj)) - gdepw_n(ji,jj,mikt(ji,jj)) -0.001_wp 
    673632               ! Compute Monin obukhov length scale at the surface and Ekman depth: 
    674633               zmob   = zustar ** 3 / (vkarmn * (zbuofdep + epsln)) 
    675634               zmols  = SIGN(1._wp, zmob) * MIN(ABS(zmob), zhmax) * tmask(ji,jj,ikt) 
    676635 
    677       !! compute eta* (stability parameter) 
    678                zetastar = 1 / ( SQRT(1 + MAX(zxsiN * zustar / ( ABS(ff(ji,jj)) * zmols * zRc ), 0.0))) 
    679  
    680       !! compute the sublayer thickness 
    681                zhnu = 5 * znu / zustar 
    682       !! compute gamma turb 
    683                zgturb = 1/vkarmn * LOG(zustar * zxsiN * zetastar * zetastar / ( ABS(ff(ji,jj)) * zhnu )) & 
    684                &      + 1 / ( 2 * zxsiN * zetastar ) - 1/vkarmn 
    685  
    686       !! compute gammats 
    687                gt = zustar / (zgturb + zgmolet) 
    688                gs = zustar / (zgturb + zgmoles) 
     636                  !! compute eta* (stability parameter) 
     637                  zetastar = 1._wp / ( SQRT(1._wp + MAX(zxsiN * zustar(ji,jj) / ( ABS(ff(ji,jj)) * zmols * zRc ), 0.0_wp))) 
     638 
     639                  !! compute the sublayer thickness 
     640                  zhnu = 5 * znu / zustar(ji,jj) 
     641 
     642                  !! compute gamma turb 
     643                  zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / ( ABS(ff(ji,jj)) * zhnu )) & 
     644                  &      + 1._wp / ( 2 * zxsiN * zetastar ) - 1._wp / vkarmn 
     645 
     646                  !! compute gammats 
     647                  pgt(ji,jj) = zustar(ji,jj) / (zgturb + zgmolet) 
     648                  pgs(ji,jj) = zustar(ji,jj) / (zgturb + zgmoles) 
    689649               END IF 
    690       END IF 
    691       ! 
    692    END SUBROUTINE 
    693  
    694  
    695    SUBROUTINE sbc_isf_tbl( varin, varout, cptin ) 
     650            END DO 
     651         END DO 
     652         CALL lbc_lnk(pgt(:,:),'T',1.) 
     653         CALL lbc_lnk(pgs(:,:),'T',1.) 
     654      END SELECT 
     655      CALL wrk_dealloc( jpi,jpj, zustar ) 
     656      ! 
     657   END SUBROUTINE sbc_isf_gammats 
     658 
     659   SUBROUTINE sbc_isf_tbl( pvarin, pvarout, cd_ptin ) 
    696660      !!---------------------------------------------------------------------- 
    697661      !!                  ***  SUBROUTINE sbc_isf_tbl  *** 
    698662      !! 
    699       !! ** Purpose : compute mean T/S/U/V in the boundary layer  
    700       !! 
    701       !!---------------------------------------------------------------------- 
    702       REAL(wp), DIMENSION(:,:,:), INTENT(in) :: varin 
    703       REAL(wp), DIMENSION(:,:)  , INTENT(out):: varout 
     663      !! ** Purpose : compute mean T/S/U/V in the boundary layer at T- point 
     664      !! 
     665      !!---------------------------------------------------------------------- 
     666      REAL(wp), DIMENSION(:,:,:), INTENT( in  ) :: pvarin 
     667      REAL(wp), DIMENSION(:,:)  , INTENT( out ) :: pvarout 
     668      CHARACTER(len=1),           INTENT( in  ) :: cd_ptin ! point of variable in/out 
     669      ! 
     670      REAL(wp) :: ze3, zhk 
     671      REAL(wp), DIMENSION(:,:), POINTER :: zhisf_tbl ! thickness of the tbl 
     672 
     673      INTEGER :: ji, jj, jk                  ! loop index 
     674      INTEGER :: ikt, ikb                    ! top and bottom index of the tbl 
     675      !!---------------------------------------------------------------------- 
     676      ! allocation 
     677      CALL wrk_alloc( jpi,jpj, zhisf_tbl) 
    704678       
    705       CHARACTER(len=1), INTENT(in) :: cptin ! point of variable in/out 
    706  
    707       REAL(wp) :: ze3, zhk 
    708       REAL(wp), DIMENSION(:,:), POINTER :: zikt 
    709  
    710       INTEGER :: ji,jj,jk 
    711       INTEGER :: ikt,ikb 
    712       INTEGER, DIMENSION(:,:), POINTER :: mkt, mkb 
    713  
    714       CALL wrk_alloc( jpi,jpj, mkt, mkb  ) 
    715       CALL wrk_alloc( jpi,jpj, zikt ) 
    716  
    717       ! get first and last level of tbl 
    718       mkt(:,:) = misfkt(:,:) 
    719       mkb(:,:) = misfkb(:,:) 
    720  
    721       varout(:,:)=0._wp 
    722       DO jj = 2,jpj 
    723          DO ji = 2,jpi 
    724             IF (ssmask(ji,jj) == 1) THEN 
    725                ikt = mkt(ji,jj) 
    726                ikb = mkb(ji,jj) 
     679      ! initialisation 
     680      pvarout(:,:)=0._wp 
     681    
     682      SELECT CASE ( cd_ptin ) 
     683      CASE ( 'U' ) ! compute U in the top boundary layer at T- point  
     684         DO jj = 1,jpj 
     685            DO ji = 1,jpi 
     686               ikt = miku(ji,jj) ; ikb = miku(ji,jj) 
     687               ! thickness of boundary layer at least the top level thickness 
     688               zhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3u_n(ji,jj,ikt)) 
     689 
     690               ! determine the deepest level influenced by the boundary layer 
     691               DO jk = ikt+1, mbku(ji,jj) 
     692                  IF ( (SUM(fse3u_n(ji,jj,ikt:jk-1)) < zhisf_tbl(ji,jj)) .AND. (umask(ji,jj,jk) == 1) ) ikb = jk 
     693               END DO 
     694               zhisf_tbl(ji,jj) = MIN(zhisf_tbl(ji,jj), SUM(fse3u_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
     695 
     696               ! level fully include in the ice shelf boundary layer 
     697               DO jk = ikt, ikb - 1 
     698                  ze3 = fse3u_n(ji,jj,jk) 
     699                  pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) / zhisf_tbl(ji,jj) * ze3 
     700               END DO 
     701 
     702               ! level partially include in ice shelf boundary layer  
     703               zhk = SUM( fse3u_n(ji, jj, ikt:ikb - 1)) / zhisf_tbl(ji,jj) 
     704               pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk) 
     705            END DO 
     706         END DO 
     707         DO jj = 2,jpj 
     708            DO ji = 2,jpi 
     709               pvarout(ji,jj) = 0.5_wp * (pvarout(ji,jj) + pvarout(ji-1,jj)) 
     710            END DO 
     711         END DO 
     712         CALL lbc_lnk(pvarout,'T',-1.) 
     713       
     714      CASE ( 'V' ) ! compute V in the top boundary layer at T- point  
     715         DO jj = 1,jpj 
     716            DO ji = 1,jpi 
     717               ikt = mikv(ji,jj) ; ikb = mikv(ji,jj) 
     718               ! thickness of boundary layer at least the top level thickness 
     719               zhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3v_n(ji,jj,ikt)) 
     720 
     721               ! determine the deepest level influenced by the boundary layer 
     722               DO jk = ikt+1, mbkv(ji,jj) 
     723                  IF ( (SUM(fse3v_n(ji,jj,ikt:jk-1)) < zhisf_tbl(ji,jj)) .AND. (vmask(ji,jj,jk) == 1) ) ikb = jk 
     724               END DO 
     725               zhisf_tbl(ji,jj) = MIN(zhisf_tbl(ji,jj), SUM(fse3v_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
     726 
     727               ! level fully include in the ice shelf boundary layer 
     728               DO jk = ikt, ikb - 1 
     729                  ze3 = fse3v_n(ji,jj,jk) 
     730                  pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) / zhisf_tbl(ji,jj) * ze3 
     731               END DO 
     732 
     733               ! level partially include in ice shelf boundary layer  
     734               zhk = SUM( fse3v_n(ji, jj, ikt:ikb - 1)) / zhisf_tbl(ji,jj) 
     735               pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk) 
     736            END DO 
     737         END DO 
     738         DO jj = 2,jpj 
     739            DO ji = 2,jpi 
     740               pvarout(ji,jj) = 0.5_wp * (pvarout(ji,jj) + pvarout(ji,jj-1)) 
     741            END DO 
     742         END DO 
     743         CALL lbc_lnk(pvarout,'T',-1.) 
     744 
     745      CASE ( 'T' ) ! compute T in the top boundary layer at T- point  
     746         DO jj = 1,jpj 
     747            DO ji = 1,jpi 
     748               ikt = misfkt(ji,jj) 
     749               ikb = misfkb(ji,jj) 
    727750 
    728751               ! level fully include in the ice shelf boundary layer 
    729752               DO jk = ikt, ikb - 1 
    730753                  ze3 = e3t_n(ji,jj,jk) 
    731                   IF (cptin == 'T' ) varout(ji,jj) = varout(ji,jj) + varin(ji,jj,jk) * r1_hisf_tbl(ji,jj) * ze3 
    732                   IF (cptin == 'U' ) varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,jk) + varin(ji-1,jj,jk)) & 
    733                      &                                                       * r1_hisf_tbl(ji,jj) * ze3 
    734                   IF (cptin == 'V' ) varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,jk) + varin(ji,jj-1,jk)) & 
    735                      &                                                       * r1_hisf_tbl(ji,jj) * ze3 
     754                  pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) * r1_hisf_tbl(ji,jj) * ze3 
    736755               END DO 
    737756 
    738757               ! level partially include in ice shelf boundary layer  
    739758               zhk = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) 
    740                IF (cptin == 'T') & 
    741                    &  varout(ji,jj) = varout(ji,jj) + varin(ji,jj,ikb) * (1._wp - zhk) 
    742                IF (cptin == 'U') & 
    743                    &  varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,ikb) + varin(ji-1,jj,ikb)) * (1._wp - zhk) 
    744                IF (cptin == 'V') & 
    745                    &  varout(ji,jj) = varout(ji,jj) + 0.5_wp * (varin(ji,jj,ikb) + varin(ji,jj-1,ikb)) * (1._wp - zhk) 
    746             END IF 
    747          END DO 
    748       END DO 
    749  
    750       CALL wrk_dealloc( jpi,jpj, mkt, mkb )       
    751       CALL wrk_dealloc( jpi,jpj, zikt )  
    752  
    753       IF (cptin == 'T') CALL lbc_lnk(varout,'T',1.) 
    754       IF (cptin == 'U' .OR. cptin == 'V') CALL lbc_lnk(varout,'T',-1.) 
     759               pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk) 
     760            END DO 
     761         END DO 
     762      END SELECT 
     763 
     764      ! mask mean tbl value 
     765      pvarout(:,:) = pvarout(:,:) * ssmask(:,:) 
     766 
     767      ! deallocation 
     768      CALL wrk_dealloc( jpi,jpj, zhisf_tbl )       
    755769      ! 
    756770   END SUBROUTINE sbc_isf_tbl 
    … …  
    769783      !! ** Action  :   phdivn   decreased by the runoff inflow 
    770784      !!---------------------------------------------------------------------- 
    771       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phdivn   ! horizontal divergence 
    772       !! 
     785      REAL(wp), DIMENSION(:,:,:), INTENT( inout ) ::   phdivn   ! horizontal divergence 
     786      !  
    773787      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    774788      INTEGER  ::   ikt, ikb  
    775       INTEGER  ::   nk_isf 
    776       REAL(wp)     ::   zhk, z1_hisf_tbl, zhisf_tbl 
    777       REAL(wp)     ::   zfact     ! local scalar 
     789      REAL(wp) ::   zhk 
     790      REAL(wp) ::   zfact     ! local scalar 
    778791      !!---------------------------------------------------------------------- 
    779792      ! 
    … …  
    789802 
    790803               ! determine the deepest level influenced by the boundary layer 
    791                ! test on tmask useless ????? 
    792804               DO jk = ikt, mbkt(ji,jj) 
    793805                  IF ( (SUM(e3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    … …  
    801813            END DO 
    802814         END DO 
    803       END IF ! vvl case 
    804       ! 
     815      END IF  
     816      ! 
     817      !==   ice shelf melting distributed over several levels   ==! 
    805818      DO jj = 1,jpj 
    806819         DO ji = 1,jpi 
    … …  
    810823               DO jk = ikt, ikb - 1 
    811824                  phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + ( fwfisf(ji,jj) + fwfisf_b(ji,jj) ) & 
    812                     &               * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact 
     825                    &              * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact 
    813826               END DO 
    814827               ! level partially include in ice shelf boundary layer  
    815828               phdivn(ji,jj,ikb) = phdivn(ji,jj,ikb) + ( fwfisf(ji,jj) & 
    816                   &             + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact * ralpha(ji,jj)  
    817             !==   ice shelf melting mass distributed over several levels   ==! 
     829                    &            + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact * ralpha(ji,jj)  
    818830         END DO 
    819831      END DO 
    820832      ! 
    821833   END SUBROUTINE sbc_isf_div 
    822  
    823  
    824    FUNCTION tinsitu( ptem, psal, ppress ) RESULT( pti ) 
    825       !!---------------------------------------------------------------------- 
    826       !!                 ***  ROUTINE eos_init  *** 
    827       !! 
    828       !! ** Purpose :   Compute the in-situ temperature [Celcius] 
    829       !! 
    830       !! ** Method  :    
    831       !! 
    832       !! Reference  :   Bryden,h.,1973,deep-sea res.,20,401-408 
    833       !!---------------------------------------------------------------------- 
    834       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   ptem   ! potential temperature [Celcius] 
    835       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   psal   ! salinity             [psu] 
    836       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   ppress ! pressure             [dBar] 
    837       REAL(wp), DIMENSION(:,:), POINTER           ::   pti    ! in-situ temperature [Celcius] 
    838 !      REAL(wp) :: fsatg 
    839 !      REAL(wp) :: pfps, pfpt, pfphp  
    840       REAL(wp) :: zt, zs, zp, zh, zq, zxk 
    841       INTEGER  :: ji, jj            ! dummy loop indices 
    842       ! 
    843       CALL wrk_alloc( jpi,jpj, pti  ) 
    844       !  
    845       DO jj=1,jpj 
    846          DO ji=1,jpi 
    847             zh = ppress(ji,jj) 
    848 ! Theta1 
    849             zt = ptem(ji,jj) 
    850             zs = psal(ji,jj) 
    851             zp = 0.0 
    852             zxk= zh * fsatg( zs, zt, zp ) 
    853             zt = zt + 0.5 * zxk 
    854             zq = zxk 
    855 ! Theta2 
    856             zp = zp + 0.5 * zh 
    857             zxk= zh*fsatg( zs, zt, zp ) 
    858             zt = zt + 0.29289322 * ( zxk - zq ) 
    859             zq = 0.58578644 * zxk + 0.121320344 * zq 
    860 ! Theta3 
    861             zxk= zh * fsatg( zs, zt, zp ) 
    862             zt = zt + 1.707106781 * ( zxk - zq ) 
    863             zq = 3.414213562 * zxk - 4.121320344 * zq 
    864 ! Theta4 
    865             zp = zp + 0.5 * zh 
    866             zxk= zh * fsatg( zs, zt, zp ) 
    867             pti(ji,jj) = zt + ( zxk - 2.0 * zq ) / 6.0 
    868          END DO 
    869       END DO 
    870       ! 
    871       CALL wrk_dealloc( jpi,jpj, pti  ) 
    872       ! 
    873    END FUNCTION tinsitu 
    874  
    875  
    876    FUNCTION fsatg( pfps, pfpt, pfphp ) 
    877       !!---------------------------------------------------------------------- 
    878       !!                 ***  FUNCTION fsatg  *** 
    879       !! 
    880       !! ** Purpose    :   Compute the Adiabatic laspse rate [Celcius].[decibar]^-1 
    881       !! 
    882       !! ** Reference  :   Bryden,h.,1973,deep-sea res.,20,401-408 
    883       !!  
    884       !! ** units      :   pressure        pfphp    decibars 
    885       !!                   temperature     pfpt     deg celsius (ipts-68) 
    886       !!                   salinity        pfps     (ipss-78) 
    887       !!                   adiabatic       fsatg    deg. c/decibar 
    888       !!---------------------------------------------------------------------- 
    889       REAL(wp) :: pfps, pfpt, pfphp  
    890       REAL(wp) :: fsatg 
    891       ! 
    892       fsatg = (((-2.1687e-16*pfpt+1.8676e-14)*pfpt-4.6206e-13)*pfphp         & 
    893         &    +((2.7759e-12*pfpt-1.1351e-10)*(pfps-35.)+((-5.4481e-14*pfpt    & 
    894         &    +8.733e-12)*pfpt-6.7795e-10)*pfpt+1.8741e-8))*pfphp             & 
    895         &    +(-4.2393e-8*pfpt+1.8932e-6)*(pfps-35.)                         & 
    896         &    +((6.6228e-10*pfpt-6.836e-8)*pfpt+8.5258e-6)*pfpt+3.5803e-5 
    897       ! 
    898     END FUNCTION fsatg 
    899     !!====================================================================== 
     834   !!====================================================================== 
    900835END MODULE sbcisf 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r6060 r6069  
    5555   USE timing         ! Timing 
    5656 
     57   USE diurnal_bulk, ONLY: & 
     58      & ln_diurnal_only  
     59 
    5760   IMPLICIT NONE 
    5861   PRIVATE 
    … …  
    8891         &             ln_traqsr, ln_dm2dc ,                                                 &   
    8992         &             nn_ice   , nn_ice_embd,                                               & 
    90          &             ln_rnf   , ln_ssr   , nn_isf   , nn_fwb    , ln_apr_dyn,              & 
     93         &             ln_rnf   , ln_ssr   , ln_isf   , nn_fwb    , ln_apr_dyn,              & 
    9194         &             ln_wave  ,                                                            & 
    9295         &             nn_lsm    
    … …  
    147150         WRITE(numout,*) '              Patm gradient added in ocean & ice Eqs.    ln_apr_dyn    = ', ln_apr_dyn 
    148151         WRITE(numout,*) '              runoff / runoff mouths                     ln_rnf        = ', ln_rnf 
    149          WRITE(numout,*) '              iceshelf formulation                       nn_isf        = ', nn_isf 
     152         WRITE(numout,*) '              iceshelf formulation                       ln_isf        = ', ln_isf 
    150153         WRITE(numout,*) '              closed sea (=0/1) (set in namdom)          nn_closea     = ', nn_closea 
    151154         WRITE(numout,*) '              nb of iterations if land-sea-mask applied  nn_lsm        = ', nn_lsm 
    … …  
    182185 
    183186      !                          ! Checks: 
    184       IF( nn_isf == 0 ) THEN                       ! variable initialisation if no ice shelf  
    185          IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'sbc_init : unable to allocate sbc_isf arrays' ) 
    186          fwfisf  (:,:)   = 0._wp   ;   fwfisf_b  (:,:)   = 0._wp 
    187          risf_tsc(:,:,:) = 0._wp   ;   risf_tsc_b(:,:,:) = 0._wp 
    188          rdivisf       = 0._wp 
     187      IF( .NOT. ln_isf ) THEN                      ! variable initialisation if no ice shelf  
     188         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
     189         fwfisf  (:,:)   = 0.0_wp ; fwfisf_b  (:,:)   = 0.0_wp 
     190         risf_tsc(:,:,:) = 0.0_wp ; risf_tsc_b(:,:,:) = 0.0_wp 
    189191      END IF 
    190192      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0._wp    ! no ice in the domain, ice fraction is always zero 
    … …  
    366368      IF( ln_icebergs    )   CALL icb_stp( kt )                   ! compute icebergs 
    367369 
    368       IF( nn_isf   /= 0  )   CALL sbc_isf( kt )                    ! compute iceshelves 
     370      IF( ln_isf         )   CALL sbc_isf( kt )                   ! compute iceshelves 
    369371 
    370372      IF( ln_rnf         )   CALL sbc_rnf( kt )                   ! add runoffs to fresh water fluxes 
    … …  
    374376      IF( nn_fwb    /= 0 )   CALL sbc_fwb( kt, nn_fwb, nn_fsbc )  ! control the freshwater budget 
    375377 
    376       IF( nn_closea == 1 )   CALL sbc_clo( kt )                   ! treatment of closed sea in the model domain  
    377       !                                                           ! (update freshwater fluxes) 
     378      ! treatment of closed sea in the model domain  
     379      ! (update freshwater fluxes) 
     380      ! Should not be ran if ln_diurnal_only 
     381      IF( .NOT.(ln_diurnal_only) .AND. (nn_closea == 1) )   CALL sbc_clo( kt )    
     382 
    378383!RBbug do not understand why see ticket 667 
    379384!clem: it looks like it is necessary for the north fold (in certain circumstances). Don't know why. 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r6060 r6069  
    143143         IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
    144144            rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     145            CALL eos_fzp( sss_m(:,:), ztfrz(:,:) ) 
    145146            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999._wp )             ! if missing data value use SST as runoffs temperature 
    146147               rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    147148            END WHERE 
    148149            WHERE( sf_t_rnf(1)%fnow(:,:,1) == -222._wp )             ! where fwf comes from melting of ice shelves or iceberg 
    149                ztfrz(:,:) = -1.9 !tfreez( sss_m(:,:) ) !PM to be discuss (trouble if sensitivity study) 
    150                rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * lfusisf * r1_rau0_rcp 
     150               rnf_tsc(:,:,jp_tem) = ztfrz(:,:) * rnf(:,:) * r1_rau0 - rnf(:,:) * rlfusisf * r1_rau0_rcp 
    151151            END WHERE 
    152152         ELSE                                                        ! use SST as runoffs temperature 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/SBC/sbctide.F90

    r6060 r6069  
    4646      INTEGER, INTENT( in ) ::   kt     ! ocean time-step 
    4747      INTEGER               ::   jk     ! dummy loop index 
     48      INTEGER               ::   nsec_day_orig     ! Temporary variable 
    4849      !!---------------------------------------------------------------------- 
    49  
    50       IF( nsec_day == NINT(0.5_wp * rdttra(1)) ) THEN      ! start a new day 
     50       
     51      IF( nsec_day == NINT(0.5_wp * rdttra(1)) .OR. kt == nit000 ) THEN      ! start a new day 
    5152         ! 
    5253         IF( kt == nit000 ) THEN 
    … …  
    5960         pot_astro(:,:) = 0._wp 
    6061         ! 
     62         ! If the run does not start from midnight then need to initialise tides 
     63         ! at the start of the current day (only occurs when kt==nit000) 
     64         ! Temporarily set nsec_day to beginning of day. 
     65         nsec_day_orig = nsec_day 
     66         IF ( nsec_day /= NINT(0.5_wp * rdttra(1)) ) THEN  
     67            kt_tide = kt - (nsec_day - 0.5_wp * rdttra(1))/rdttra(1) 
     68            nsec_day = NINT(0.5_wp * rdttra(1)) 
     69         ELSE 
     70            kt_tide = kt  
     71         ENDIF 
    6172         CALL tide_harmo( omega_tide, v0tide, utide, ftide, ntide, nb_harmo ) 
    6273         ! 
    63          kt_tide = kt 
    6474         ! 
    6575         IF(lwp) THEN 
    … …  
    7484         IF( ln_tide_pot )   CALL tide_init_potential 
    7585         ! 
     86         ! Reset nsec_day 
     87         nsec_day = nsec_day_orig  
    7688      ENDIF 
    7789      ! 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r6060 r6069  
    238238      ENDIF 
    239239      IF( ln_isfcav ) THEN                                                       ! ice-shelf cavities 
    240          IF(  ln_traadv_cen .AND. nn_cen_v /= 4    .OR.   &                            ! NO 4th order with ISF 
    241             & ln_traadv_fct .AND. nn_fct_v /= 4   )   CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' ) 
     240         IF(  ln_traadv_cen .AND. nn_cen_v == 4    .OR.   &                            ! NO 4th order with ISF 
     241            & ln_traadv_fct .AND. nn_fct_v == 4   )   CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' ) 
    242242      ENDIF 
    243243      ! 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r6060 r6069  
    100100      ! 
    101101      CALL wrk_alloc( jpi,jpj,jpk,jpts,   zts_dta ) 
    102       ! 
    103102      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    104103         CALL wrk_alloc( jpi,jpj,jpk,jpts,   ztrdts )  

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r6060 r6069  
    102102      ! 
    103103      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
     104      INTEGER  ::  ikt 
    104105      INTEGER  ::  ierr             ! local integer 
    105106      REAL(wp) ::  zmsku, zahu_w, zabe1, zcof1, zcoef3   ! local scalars 
    … …  
    225226            DO jj = 1, jpjm1              ! bottom correction (partial bottom cell) 
    226227               DO ji = 1, fs_jpim1   ! vector opt. 
    227 !!gm  the following anonymous remark is to considered: ! IF useless if zpshde defines pgu everywhere 
    228228                  zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    229229                  zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    … …  
    252252            ELSE                 ;   zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * wmask(:,:,jk) 
    253253            ENDIF 
    254 !!gm I don't understand why we should need this.... since wmask is used instead of tmask 
    255 !         IF ( ln_isfcav ) THEN 
    256 !            DO jj = 1, jpj 
    257 !               DO ji = 1, jpi   ! vector opt. 
    258 !                  ikt = mikt(ji,jj) ! surface level 
    259 !                  zdk1t(ji,jj,ikt) = ( ptb(ji,jj,ikt,jn  ) - ptb(ji,jj,ikt+1,jn) ) * wmask(ji,jj,ikt+1) 
    260 !                  zdkt (ji,jj,ikt) = zdk1t(ji,jj,ikt) 
    261 !               END DO 
    262 !            END DO 
    263 !         END IF 
    264 !!gm  
    265254            DO jj = 1 , jpjm1            !==  Horizontal fluxes 
    266255               DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    268257                  zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) 
    269258                  ! 
    270                   zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
    271                      &             + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk  ), 1. ) 
    272                   ! 
    273                   zmskv = 1. / MAX(  tmask(ji,jj+1,jk  ) + tmask(ji,jj,jk+1)   & 
    274                      &             + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk  ), 1. ) 
     259                  zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   & 
     260                     &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     261                  ! 
     262                  zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   & 
     263                     &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. ) 
    275264                  ! 
    276265                  zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r6060 r6069  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    2929   USE sbcrnf          ! river runoffs 
    30    USE sbcisf          ! ice shelf melting/freezing 
     30   USE sbcisf          ! ice shelf melting 
    3131   USE zdf_oce         ! ocean vertical mixing 
    3232   USE domvvl          ! variable volume 
    … …  
    259259      ENDIF 
    260260      ! 
    261       IF( cdtype == 'TRA' )  THEN   ! active  tracers case  
    262          ll_traqsr  = ln_traqsr        ! solar penetration 
    263          ll_rnf     = ln_rnf           ! river runoffs 
    264          IF( nn_isf >= 1 ) THEN  
    265             ll_isf = .TRUE.            ! ice shelf melting/freezing 
    266          ELSE 
    267             ll_isf = .FALSE. 
    268          END IF 
     261      IF( cdtype == 'TRA' )  THEN    
     262         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
     263         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
     264         ll_isf     = ln_isf           ! active  tracers case  and  ice shelf melting 
    269265      ELSE                          ! passive tracers case 
    270266         ll_traqsr  = .FALSE.          ! NO solar penetration 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r6060 r6069  
    2323   USE sbcrnf         ! River runoff   
    2424   USE sbcisf         ! Ice shelf    
     25   USE iscplini       ! Ice sheet coupling 
    2526   USE traqsr         ! solar radiation penetration 
    2627   USE trd_oce        ! trends: ocean variables 
    … …  
    7475      INTEGER  ::   ikt, ikb              ! local integers 
    7576      REAL(wp) ::   zfact, z1_e3t, zdep   ! local scalar 
    76       REAL(wp) ::   zalpha, zhk           !   -      - 
    7777      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    7878      !!---------------------------------------------------------------------- 
    … …  
    155155!!gm BUG ?   Why no differences between non-linear and linear free surface ? 
    156156!!gm         probably taken into account in r1_hisf_tbl : to be verified 
    157       ! 
    158       IF( nn_isf > 0 ) THEN 
     157      IF( ln_isf ) THEN 
    159158         zfact = 0.5_wp 
    160159         DO jj = 2, jpj 
    … …  
    165164               ! 
    166165               ! level fully include in the ice shelf boundary layer 
    167                ! if isfdiv, we have to remove heat flux due to inflow at 0oC (as in rnf when you add rnf at sst) 
    168166               ! sign - because fwf sign of evapo (rnf sign of precip) 
    169167               DO jk = ikt, ikb - 1 
    170                ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    171168               ! compute trend 
    172                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                          & 
    173                      &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 
    174                   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    175                      &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
     169                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                                & 
     170                     &           + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             & 
     171                     &           * r1_hisf_tbl(ji,jj) 
    176172               END DO 
    177173    
    178174               ! level partially include in ice shelf boundary layer  
    179                ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    180175               ! compute trend 
    181                tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                           & 
    182                   &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    183                tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    184                   &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  
     176               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                                 & 
     177                  &              + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             & 
     178                  &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
     179 
    185180            END DO 
    186181         END DO 
    … …  
    213208      ENDIF 
    214209      ! 
    215       IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
     210      !---------------------------------------- 
     211      !        Ice Sheet coupling imbalance correction to have conservation 
     212      !---------------------------------------- 
     213      ! 
     214      IF( ln_iscpl .AND. ln_hsb) THEN         ! input of heat and salt due to river runoff  
     215         DO jk = 1,jpk 
     216            DO jj = 2, jpj  
     217               DO ji = fs_2, fs_jpim1 
     218                  zdep = 1._wp / fse3t_n(ji,jj,jk)  
     219                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) - htsc_iscpl(ji,jj,jk,jp_tem)                       & 
     220                      &                                         * zdep 
     221                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) - htsc_iscpl(ji,jj,jk,jp_sal)                       & 
     222                      &                                         * zdep   
     223               END DO   
     224            END DO   
     225         END DO 
     226      ENDIF 
     227 
     228      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
    216229         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    217230         ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90

    r6060 r6069  
    191191      ! 
    192192   END SUBROUTINE zps_hde 
    193  
    194  
    195    SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu , pgtv , pgtui, pgtvi,                                   & 
    196       &                              prd, pgru , pgrv , pmru , pmrv , pgzu , pgzv , pge3ru , pge3rv ,   & 
    197       &                                   pgrui, pgrvi, pmrui, pmrvi, pgzui, pgzvi, pge3rui, pge3rvi ) 
    198       !!---------------------------------------------------------------------- 
    199       !!                     ***  ROUTINE zps_hde  *** 
     193   ! 
     194   SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi,  & 
     195      &                          prd, pgru, pgrv, pgrui, pgrvi ) 
     196      !!---------------------------------------------------------------------- 
     197      !!                     ***  ROUTINE zps_hde_isf  *** 
    200198      !!                     
    201199      !! ** Purpose :   Compute the horizontal derivative of T, S and rho 
    202200      !!      at u- and v-points with a linear interpolation for z-coordinate 
    203       !!      with partial steps. 
     201      !!      with partial steps for top (ice shelf) and bottom. 
    204202      !! 
    205203      !! ** Method  :   In z-coord with partial steps, scale factors on last  
    206204      !!      levels are different for each grid point, so that T, S and rd  
    207205      !!      points are not at the same depth as in z-coord. To have horizontal 
    208       !!      gradients again, we interpolate T and S at the good depth :  
     206      !!      gradients again, we interpolate T and S at the good depth : 
     207      !!      For the bottom case: 
    209208      !!      Linear interpolation of T, S    
    210209      !!         Computation of di(tb) and dj(tb) by vertical interpolation: 
    … …  
    235234      !!          di(rho) = rd~ - rd(i,j,k)   or   rd(i+1,j,k) - rd~ 
    236235      !! 
     236      !!      For the top case (ice shelf): As for the bottom case but upside down 
     237      !! 
    237238      !! ** Action  : compute for top and bottom interfaces 
    238239      !!              - pgtu, pgtv, pgtui, pgtvi: horizontal gradient of tracer at u- & v-points 
    239240      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 
    240       !!              - pmru, pmrv, pmrui, pmrvi: horizontal sum of rho at u- & v- point (used in dynhpg with vvl) 
    241       !!              - pgzu, pgzv, pgzui, pgzvi: horizontal gradient of z at u- and v- point (used in dynhpg with vvl) 
    242       !!              - pge3ru, pge3rv, pge3rui, pge3rvi: horizontal gradient of rho weighted by local e3w at u- & v-points  
    243       !!---------------------------------------------------------------------- 
    244       INTEGER                              , INTENT(in   )           ::  kt                ! ocean time-step index 
    245       INTEGER                              , INTENT(in   )           ::  kjpt              ! number of tracers 
    246       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta               ! 4D tracers fields 
    247       !                                                              !!  u-point ! v-point ! 
    248       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu    , pgtv    ! bottom GRADh( ptra )   
    249       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui   , pgtvi   ! top    GRADh( ptra ) 
    250       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd               ! 3D density anomaly fields 
    251       !                                                              !!  u-point ! v-point ! 
    252       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru    , pgrv    ! bottom GRADh( prd  ) 
    253       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pmru    , pmrv    ! bottom SUM  ( prd  ) 
    254       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzu    , pgzv    ! bottom GRADh( z    )  
    255       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3ru  , pge3rv  ! bottom GRADh( prd  ) weighted by e3w 
    256       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui   , pgrvi   ! top    GRADh( prd  )  
    257       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pmrui   , pmrvi   ! top    SUM  ( prd  )  
    258       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgzui   , pgzvi   ! top    GRADh( z    )  
    259       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pge3rui , pge3rvi ! top    GRADh( prd  ) weighted by e3w 
     241      !!---------------------------------------------------------------------- 
     242      INTEGER                              , INTENT(in   )           ::  kt           ! ocean time-step index 
     243      INTEGER                              , INTENT(in   )           ::  kjpt         ! number of tracers 
     244      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta          ! 4D tracers fields 
     245      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv   ! hor. grad. of ptra at u- & v-pts  
     246      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 
     247      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd          ! 3D density anomaly fields 
     248      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv   ! hor. grad of prd at u- & v-pts (bottom) 
     249      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 
    260250      ! 
    261251      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    262252      INTEGER  ::   iku, ikv, ikum1, ikvm1,ikup1, ikvp1   ! partial step level (ocean bottom level) at u- and v-points 
    263       REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv, zdzwu, zdzwv, zdzwuip1, zdzwvjp1  ! temporary scalars 
     253      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv             ! temporary scalars 
    264254      REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    265255      REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
    … …  
    277267         DO jj = 1, jpjm1 
    278268            DO ji = 1, jpim1 
    279                iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    280                ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     269 
     270               iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     271               ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     272               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
     273               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
     274               ! 
     275               ! i- direction 
     276               IF( ze3wu >= 0._wp ) THEN      ! case 1 
     277                  zmaxu =  ze3wu / e3w_n(ji+1,jj,iku) 
     278                  ! interpolated values of tracers 
     279                  zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     280                  ! gradient of  tracers 
     281                  pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     282               ELSE                           ! case 2 
     283                  zmaxu = -ze3wu / e3w_n(ji,jj,iku) 
     284                  ! interpolated values of tracers 
     285                  zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     286                  ! gradient of tracers 
     287                  pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     288               ENDIF 
     289               ! 
     290               ! j- direction 
     291               IF( ze3wv >= 0._wp ) THEN      ! case 1 
     292                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv) 
     293                  ! interpolated values of tracers 
     294                  ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     295                  ! gradient of tracers 
     296                  pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     297               ELSE                           ! case 2 
     298                  zmaxv =  -ze3wv / e3w_n(ji,jj,ikv) 
     299                  ! interpolated values of tracers 
     300                  ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     301                  ! gradient of tracers 
     302                  pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     303               ENDIF 
     304 
     305            END DO 
     306         END DO 
     307         CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     308         ! 
     309      END DO 
     310 
     311      ! horizontal derivative of density anomalies (rd) 
     312      IF( PRESENT( prd ) ) THEN         ! depth of the partial step level 
     313         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
     314         ! 
     315         DO jj = 1, jpjm1 
     316            DO ji = 1, jpim1 
     317 
     318               iku = mbku(ji,jj) 
     319               ikv = mbkv(ji,jj) 
     320               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
     321               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
     322               ! 
     323               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1 
     324               ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2 
     325               ENDIF 
     326               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1 
     327               ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2 
     328               ENDIF 
     329 
     330            END DO 
     331         END DO 
     332 
     333         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
     334         ! step and store it in  zri, zrj for each  case 
     335         CALL eos( zti, zhi, zri ) 
     336         CALL eos( ztj, zhj, zrj ) 
     337 
     338         DO jj = 1, jpjm1                 ! Gradient of density at the last level  
     339            DO ji = 1, jpim1 
     340               iku = mbku(ji,jj) 
     341               ikv = mbkv(ji,jj) 
     342               ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
     343               ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
     344 
     345               IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     346               ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     347               ENDIF 
     348               IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     349               ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     350               ENDIF 
     351 
     352            END DO 
     353         END DO 
     354 
     355         CALL lbc_lnk( pgru , 'U', -1. )   ;   CALL lbc_lnk( pgrv , 'V', -1. )   ! Lateral boundary conditions 
     356         ! 
     357      END IF 
     358      ! 
     359      !     !==  (ISH)  compute grui and gruvi  ==! 
     360      ! 
     361      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
     362         DO jj = 1, jpjm1 
     363            DO ji = 1, jpim1 
     364               iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
     365               ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
     366               ! 
    281367               ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    282368               ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    283369               ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
    284370               ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    285                ze3wu  = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 
    286                ze3wv  = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 
    287                ! 
     371               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
     372               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
     373 
    288374               ! i- direction 
    289375               IF( ze3wu >= 0._wp ) THEN      ! case 1 
    290                   zmaxu =  ze3wu / e3w_n(ji+1,jj,iku) 
    291                   ! interpolated values of tracers 
    292                   zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     376                  zmaxu = ze3wu / e3w_n(ji+1,jj,ikup1) 
     377                  ! interpolated values of tracers 
     378                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) 
     379                  ! gradient of tracers 
     380                  pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     381               ELSE                           ! case 2 
     382                  zmaxu = - ze3wu / e3w_n(ji,jj,ikup1) 
     383                  ! interpolated values of tracers 
     384                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) 
    293385                  ! gradient of  tracers 
    294                   pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    295                ELSE                           ! case 2 
    296                   zmaxu = -ze3wu / e3w_n(ji,jj,iku) 
    297                   ! interpolated values of tracers 
    298                   zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    299                   ! gradient of tracers 
    300                   pgtu(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     386                  pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    301387               ENDIF 
    302388               ! 
    303389               ! j- direction 
    304390               IF( ze3wv >= 0._wp ) THEN      ! case 1 
    305                   zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv) 
    306                   ! interpolated values of tracers 
    307                   ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    308                   ! gradient of tracers 
    309                   pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    310                ELSE                           ! case 2 
    311                   zmaxv =  -ze3wv / e3w_n(ji,jj,ikv) 
    312                   ! interpolated values of tracers 
    313                   ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    314                   ! gradient of tracers 
    315                   pgtv(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    316                ENDIF 
    317             END DO 
    318          END DO 
    319          CALL lbc_lnk( pgtu(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtv(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
     391                  zmaxv =  ze3wv / e3w_n(ji,jj+1,ikvp1) 
     392                  ! interpolated values of tracers 
     393                  ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) 
     394                  ! gradient of tracers 
     395                  pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     396               ELSE                           ! case 2 
     397                  zmaxv =  - ze3wv / e3w_n(ji,jj,ikvp1) 
     398                  ! interpolated values of tracers 
     399                  ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) 
     400                  ! gradient of tracers 
     401                  pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     402               ENDIF 
     403 
     404            END DO 
     405         END DO 
     406         CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. ); CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    320407         ! 
    321408      END DO 
    … …  
    323410      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    324411         ! 
    325          pgru  (:,:)=0._wp   ;   pgrv  (:,:) = 0._wp 
    326          pgzu  (:,:)=0._wp   ;   pgzv  (:,:) = 0._wp  
    327          pmru  (:,:)=0._wp   ;   pmru  (:,:) = 0._wp  
    328          pge3ru(:,:)=0._wp   ;   pge3rv(:,:) = 0._wp  
    329          ! 
    330          DO jj = 1, jpjm1                 ! depth of the partial step level 
    331             DO ji = 1, jpim1 
    332                iku = mbku(ji,jj) 
    333                ikv = mbkv(ji,jj) 
    334                ze3wu  = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 
    335                ze3wv  = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 
    336                ! 
    337                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku) - ze3wu     ! i-direction: case 1 
    338                ELSE                        ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku) + ze3wu    ! -     -      case 2 
    339                ENDIF 
    340                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv) - ze3wv    ! j-direction: case 1 
    341                ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv) + ze3wv    ! -     -      case 2 
    342                ENDIF 
     412         pgrui(:,:)  =0.0_wp; pgrvi(:,:)  =0.0_wp; 
     413         DO jj = 1, jpjm1 
     414            DO ji = 1, jpim1 
     415 
     416               iku = miku(ji,jj) 
     417               ikv = mikv(ji,jj) 
     418               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
     419               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
     420               ! 
     421               IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku)    ! i-direction: case 1 
     422               ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku)    ! -     -      case 2 
     423               ENDIF 
     424 
     425               IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv)    ! j-direction: case 1 
     426               ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv)    ! -     -      case 2 
     427               ENDIF 
     428 
    343429            END DO 
    344430         END DO 
    … …  
    346432         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
    347433         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    348  
     434         ! 
    349435         DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    350436            DO ji = 1, jpim1 
    351                iku = mbku(ji,jj) ; ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    352                ikv = mbkv(ji,jj) ; ikvm1 = MAX( ikv - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    353                ze3wu  = (gdept_0(ji+1,jj,iku) - gdepw_0(ji+1,jj,iku)) - (gdept_0(ji,jj,iku) - gdepw_0(ji,jj,iku)) 
    354                ze3wv  = (gdept_0(ji,jj+1,ikv) - gdepw_0(ji,jj+1,ikv)) - (gdept_0(ji,jj,ikv) - gdepw_0(ji,jj,ikv)) 
    355                IF( ze3wu >= 0._wp ) THEN  
    356                   pgzu(ji,jj) = (gde3w_n(ji+1,jj,iku) - ze3wu) - gde3w_n(ji,jj,iku) 
    357                   pgru(ji,jj) = umask(ji,jj,iku) * ( zri(ji  ,jj) - prd(ji,jj,iku) )   ! i: 1 
    358                   pmru(ji,jj) = umask(ji,jj,iku) * ( zri(ji  ,jj) + prd(ji,jj,iku) )   ! i: 1  
    359                   pge3ru(ji,jj) = umask(ji,jj,iku)                                                                  & 
    360                                 * ( (e3w_n(ji+1,jj,iku) - ze3wu )* ( zri(ji  ,jj    ) + prd(ji+1,jj,ikum1) + 2._wp) & 
    361                                    - e3w_n(ji  ,jj,iku)          * ( prd(ji  ,jj,iku) + prd(ji  ,jj,ikum1) + 2._wp) )  ! j: 2 
    362                ELSE   
    363                   pgzu(ji,jj) = gde3w_n(ji+1,jj,iku) - (gde3w_n(ji,jj,iku) + ze3wu) 
    364                   pgru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) - zri(ji,jj) )   ! i: 2 
    365                   pmru(ji,jj) = umask(ji,jj,iku) * ( prd(ji+1,jj,iku) + zri(ji,jj) )   ! i: 2 
    366                   pge3ru(ji,jj) = umask(ji,jj,iku)                                                                  & 
    367                                 * (  e3w_n(ji+1,jj,iku)          * ( prd(ji+1,jj,iku) + prd(ji+1,jj,ikum1) + 2._wp) & 
    368                                    -(e3w_n(ji  ,jj,iku) + ze3wu) * ( zri(ji  ,jj    ) + prd(ji  ,jj,ikum1) + 2._wp) )  ! j: 2 
    369                ENDIF 
    370                IF( ze3wv >= 0._wp ) THEN 
    371                   pgzv(ji,jj) = (gde3w_n(ji,jj+1,ikv) - ze3wv) - gde3w_n(ji,jj,ikv)  
    372                   pgrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )   ! j: 1 
    373                   pmrv(ji,jj) = vmask(ji,jj,ikv) * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )   ! j: 1 
    374                   pge3rv(ji,jj) = vmask(ji,jj,ikv)                                                                  & 
    375                                 * ( (e3w_n(ji,jj+1,ikv) - ze3wv )* ( zrj(ji,jj      ) + prd(ji,jj+1,ikvm1) + 2._wp) & 
    376                                    - e3w_n(ji,jj  ,ikv)          * ( prd(ji,jj  ,ikv) + prd(ji,jj  ,ikvm1) + 2._wp) )  ! j: 2 
    377                ELSE  
    378                   pgzv(ji,jj) = gde3w_n(ji,jj+1,ikv) - (gde3w_n(ji,jj,ikv) + ze3wv) 
    379                   pgrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )   ! j: 2 
    380                   pmrv(ji,jj) = vmask(ji,jj,ikv) * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )   ! j: 2 
    381                   pge3rv(ji,jj) = vmask(ji,jj,ikv)                                                                  & 
    382                                 * (  e3w_n(ji,jj+1,ikv)          * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikvm1) + 2._wp) & 
    383                                    -(e3w_n(ji,jj  ,ikv) + ze3wv) * ( zrj(ji,jj      ) + prd(ji,jj  ,ikvm1) + 2._wp) )  ! j: 2 
    384                ENDIF 
    385             END DO 
    386          END DO 
    387          CALL lbc_lnk( pgru   , 'U', -1. )   ;   CALL lbc_lnk( pgrv   , 'V', -1. )   ! Lateral boundary conditions 
    388          CALL lbc_lnk( pmru   , 'U',  1. )   ;   CALL lbc_lnk( pmrv   , 'V',  1. )   ! Lateral boundary conditions 
    389          CALL lbc_lnk( pgzu   , 'U', -1. )   ;   CALL lbc_lnk( pgzv   , 'V', -1. )   ! Lateral boundary conditions 
    390          CALL lbc_lnk( pge3ru , 'U', -1. )   ;   CALL lbc_lnk( pge3rv , 'V', -1. )   ! Lateral boundary conditions 
    391          ! 
    392       END IF 
    393       ! 
    394       !     !==  (ISH)  compute grui and gruvi  ==! 
    395       ! 
    396       DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
    397          DO jj = 1, jpjm1 
    398             DO ji = 1, jpim1 
    399                iku = miku(ji,jj)   ;  ikup1 = miku(ji,jj) + 1 
    400                ikv = mikv(ji,jj)   ;  ikvp1 = mikv(ji,jj) + 1 
    401                ! 
    402                ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    403                ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    404                ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
    405                ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    406                ze3wu  = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku))  
    407                ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    408                ! i- direction 
    409                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    410                   zmaxu = ze3wu / e3w_n(ji+1,jj,iku+1) 
    411                   ! interpolated values of tracers 
    412                   zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,iku+1,jn) - pta(ji+1,jj,iku,jn) ) 
    413                   ! gradient of tracers 
    414                   pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    415                ELSE                           ! case 2 
    416                   zmaxu = - ze3wu / e3w_n(ji,jj,iku+1) 
    417                   ! interpolated values of tracers 
    418                   zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,iku+1,jn) - pta(ji,jj,iku,jn) ) 
    419                   ! gradient of  tracers 
    420                   pgtui(ji,jj,jn) = umask(ji,jj,iku) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    421                ENDIF 
    422                ! 
    423                ! j- direction 
    424                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    425                   zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv+1) 
    426                   ! interpolated values of tracers 
    427                   ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikv+1,jn) - pta(ji,jj+1,ikv,jn) ) 
    428                   ! gradient of tracers 
    429                   pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    430                ELSE                           ! case 2 
    431                   zmaxv =  - ze3wv / e3w_n(ji,jj,ikv+1) 
    432                   ! interpolated values of tracers 
    433                   ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikv+1,jn) - pta(ji,jj,ikv,jn) ) 
    434                   ! gradient of tracers 
    435                   pgtvi(ji,jj,jn) = vmask(ji,jj,ikv) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    436                ENDIF 
    437             END DO!! 
    438          END DO!! 
    439          CALL lbc_lnk( pgtui(:,:,jn), 'U', -1. )   ;   CALL lbc_lnk( pgtvi(:,:,jn), 'V', -1. )   ! Lateral boundary cond. 
    440          ! 
    441       END DO 
    442  
    443       IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    444          ! 
    445          pgrui(:,:)  =0.0_wp ; pgrvi(:,:)  =0.0_wp ; 
    446          pgzui(:,:)  =0.0_wp ; pgzvi(:,:)  =0.0_wp ; 
    447          pmrui(:,:)  =0.0_wp ; pmrui(:,:)  =0.0_wp ; 
    448          pge3rui(:,:)=0.0_wp ; pge3rvi(:,:)=0.0_wp ; 
    449          ! 
    450          DO jj = 1, jpjm1        ! depth of the partial step level 
    451             DO ji = 1, jpim1 
    452                iku = miku(ji,jj) 
    453                ikv = mikv(ji,jj) 
    454                ze3wu = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 
    455                ze3wv = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    456                ! 
    457                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku) + ze3wu    ! i-direction: case 1 
    458                ELSE                        ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku) - ze3wu    ! -     -      case 2 
    459                ENDIF 
    460                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv) + ze3wv    ! j-direction: case 1 
    461                ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv) - ze3wv    ! -     -      case 2 
    462                ENDIF 
    463             END DO 
    464          END DO 
    465          ! 
    466          CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
    467          CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    468          ! 
    469          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    470             DO ji = 1, jpim1 
    471                iku = miku(ji,jj) ; ikup1 = miku(ji,jj) + 1 
    472                ikv = mikv(ji,jj) ; ikvp1 = mikv(ji,jj) + 1 
    473                ze3wu  = (gdepw_0(ji+1,jj,iku+1) - gdept_0(ji+1,jj,iku)) - (gdepw_0(ji,jj,iku+1) - gdept_0(ji,jj,iku)) 
    474                ze3wv  = (gdepw_0(ji,jj+1,ikv+1) - gdept_0(ji,jj+1,ikv)) - (gdepw_0(ji,jj,ikv+1) - gdept_0(ji,jj,ikv)) 
    475                IF( ze3wu >= 0._wp ) THEN 
    476                  pgzui  (ji,jj) = (gde3w_n(ji+1,jj,iku) + ze3wu) - gde3w_n(ji,jj,iku) 
    477                  pgrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) - prd(ji,jj,iku) )          ! i: 1 
    478                  pmrui  (ji,jj) = umask(ji,jj,iku)   * ( zri(ji,jj) + prd(ji,jj,iku) )          ! i: 1  
    479                  pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                  & 
    480                     &           * ( (e3w_n(ji+1,jj,iku+1) - ze3wu) * (zri(ji,jj    ) + prd(ji+1,jj,iku+1) + 2._wp)   & 
    481                     &              - e3w_n(ji  ,jj,iku+1)          * (prd(ji,jj,iku) + prd(ji  ,jj,iku+1) + 2._wp)   ) ! i: 1 
    482                ELSE 
    483                  pgzui  (ji,jj) = gde3w_n(ji+1,jj,iku) - (gde3w_n(ji,jj,iku) - ze3wu) 
    484                  pgrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) - zri(ji,jj) )      ! i: 2 
    485                  pmrui  (ji,jj) = umask(ji,jj,iku)   * ( prd(ji+1,jj,iku) + zri(ji,jj) )      ! i: 2 
    486                  pge3rui(ji,jj) = umask(ji,jj,iku+1)                                                                   & 
    487                     &           * (  e3w_n(ji+1,jj,iku+1)          * (prd(ji+1,jj,iku) + prd(ji+1,jj,iku+1) + 2._wp)  & 
    488                     &              -(e3w_n(ji  ,jj,iku+1) + ze3wu) * (zri(ji,jj      ) + prd(ji  ,jj,iku+1) + 2._wp)  )     ! i: 2 
    489                ENDIF 
    490                IF( ze3wv >= 0._wp ) THEN 
    491                  pgzvi  (ji,jj) = (gde3w_n(ji,jj+1,ikv) + ze3wv) - gde3w_n(ji,jj,ikv)  
    492                  pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) - prd(ji,jj,ikv) )        ! j: 1 
    493                  pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( zrj(ji,jj  ) + prd(ji,jj,ikv) )        ! j: 1 
    494                  pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                  &  
    495                      &           * ( (e3w_n(ji,jj+1,ikv+1) - ze3wv) * ( zrj(ji,jj    ) + prd(ji,jj+1,ikv+1) + 2._wp)  & 
    496                      &              - e3w_n(ji,jj  ,ikv+1)          * ( prd(ji,jj,ikv) + prd(ji,jj  ,ikv+1) + 2._wp)  ) ! j: 1 
    497                                   ! + 2 due to the formulation in density and not in anomalie in hpg sco 
    498                ELSE 
    499                  pgzvi  (ji,jj) = gde3w_n(ji,jj+1,ikv) - (gde3w_n(ji,jj,ikv) - ze3wv) 
    500                  pgrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) - zrj(ji,jj) )     ! j: 2 
    501                  pmrvi  (ji,jj) = vmask(ji,jj,ikv)   * ( prd(ji,jj+1,ikv) + zrj(ji,jj) )     ! j: 2 
    502                  pge3rvi(ji,jj) = vmask(ji,jj,ikv+1)                                                                   & 
    503                     &           * (  e3w_n(ji,jj+1,ikv+1)          * ( prd(ji,jj+1,ikv) + prd(ji,jj+1,ikv+1) + 2._wp) & 
    504                     &              -(e3w_n(ji,jj  ,ikv+1) + ze3wv) * ( zrj(ji,jj      ) + prd(ji,jj  ,ikv+1) + 2._wp) )  ! j: 2 
    505                ENDIF 
    506             END DO 
    507          END DO 
    508          CALL lbc_lnk( pgrui   , 'U', -1. )   ;   CALL lbc_lnk( pgrvi   , 'V', -1. )   ! Lateral boundary conditions 
    509          CALL lbc_lnk( pmrui   , 'U',  1. )   ;   CALL lbc_lnk( pmrvi   , 'V',  1. )   ! Lateral boundary conditions 
    510          CALL lbc_lnk( pgzui   , 'U', -1. )   ;   CALL lbc_lnk( pgzvi   , 'V', -1. )   ! Lateral boundary conditions 
    511          CALL lbc_lnk( pge3rui , 'U', -1. )   ;   CALL lbc_lnk( pge3rvi , 'V', -1. )   ! Lateral boundary conditions 
     437               iku = miku(ji,jj)  
     438               ikv = mikv(ji,jj)  
     439               ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
     440               ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
     441 
     442               IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1 
     443               ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2 
     444               ENDIF 
     445               IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1 
     446               ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2 
     447               ENDIF 
     448 
     449            END DO 
     450         END DO 
     451         CALL lbc_lnk( pgrui   , 'U', -1. ); CALL lbc_lnk( pgrvi   , 'V', -1. )   ! Lateral boundary conditions 
    512452         ! 
    513453      END IF   

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r6060 r6069  
    3131   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmld    !: mixing layer depth (turbocline)      [m] 
    3232   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlp    !: mixed layer depth  (rho=rho0+zdcrit) [m] 
    33    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: mixed layer depth at t-points        [m] 
     33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: depth of the last T-point inside the mixed layer 
    3434 
    3535   REAL(wp), PUBLIC ::   rho_c = 0.01_wp    !: density criterion for mixed layer depth 
    … …  
    109109      END DO 
    110110      ! 
    111       ! w-level of the turbocline 
     111      ! w-level of the turbocline and mixing layer (iom_use) 
    112112      imld(:,:) = mbkt(:,:) + 1        ! Initialization to the number of w ocean point 
    113113      DO jk = jpkm1, nlb10, -1         ! from the bottom to nlb10  
    114114         DO jj = 1, jpj 
    115115            DO ji = 1, jpi 
    116                imkt = mikt(ji,jj) 
    117                IF( avt (ji,jj,jk) < avt_c )   imld(ji,jj) = MAX( imkt, jk )      ! Turbocline  
     116               IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
    118117            END DO 
    119118         END DO 
    … …  
    125124            iikn = nmln(ji,jj) 
    126125            imkt = mikt(ji,jj) 
    127             hmld (ji,jj) = ( gdepw_n(ji,jj,iiki  ) - gdepw_n(ji,jj,imkt )            )  * ssmask(ji,jj)    ! Turbocline depth  
    128             hmlp (ji,jj) = ( gdepw_n(ji,jj,iikn  ) - gdepw_n(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj)    ! Mixed layer depth 
    129             hmlpt(ji,jj) = ( gdept_n(ji,jj,iikn-1) - gdepw_n(ji,jj,imkt )            )  * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
     126            hmld (ji,jj) = gdepw(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth  
     127            hmlp (ji,jj) = gdepw(ji,jj,iikn ) * ssmask(ji,jj)    ! Mixed layer depth 
     128            hmlpt(ji,jj) = gdept(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
    130129         END DO 
    131130      END DO 
    132131      IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    133          CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
    134          CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
     132         IF ( iom_use("mldr10_1") ) THEN 
     133            IF( .NOT. ln_isfcav ) CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     134            IF(       ln_isfcav ) CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     135         END IF 
     136         IF ( iom_use("mldkz5") ) THEN 
     137            IF( .NOT. ln_isfcav ) CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     138            IF(       ln_isfcav ) CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     139         END IF 
    135140      ENDIF 
    136141       

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90

    r4161 r6069  
    2424   PRIVATE 
    2525 
    26    PUBLIC   glob_sum   ! used in many places 
    27    PUBLIC   DDPDD      ! also used in closea module 
     26   PUBLIC   glob_sum      ! used in many places (masked with tmask_i) 
     27   PUBLIC   glob_sum_full ! used in many places (masked with tmask_h, ie omly over the halos) 
     28   PUBLIC   DDPDD         ! also used in closea module 
    2829   PUBLIC   glob_min, glob_max 
    2930#if defined key_nosignedzero 
    … …  
    3435      MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d, & 
    3536         &             glob_sum_2d_a, glob_sum_3d_a 
     37   END INTERFACE 
     38   INTERFACE glob_sum_full 
     39      MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_3d 
    3640   END INTERFACE 
    3741   INTERFACE glob_min 
    … …  
    156160      ! 
    157161   END FUNCTION glob_sum_3d_a 
     162 
     163   FUNCTION glob_sum_full_2d( ptab ) 
     164      !!---------------------------------------------------------------------- 
     165      !!                  ***  FUNCTION  glob_sum_full_2d *** 
     166      !! 
     167      !! ** Purpose : perform a sum in calling DDPDD routine (nomask) 
     168      !!---------------------------------------------------------------------- 
     169      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab 
     170      REAL(wp)                             ::   glob_sum_full_2d   ! global sum 
     171      !! 
     172      !!----------------------------------------------------------------------- 
     173      ! 
     174      glob_sum_full_2d = SUM( ptab(:,:) * tmask_h(:,:) ) 
     175      IF( lk_mpp )   CALL mpp_sum( glob_sum_full_2d ) 
     176      ! 
     177   END FUNCTION glob_sum_full_2d 
     178 
     179   FUNCTION glob_sum_full_3d( ptab ) 
     180      !!---------------------------------------------------------------------- 
     181      !!                  ***  FUNCTION  glob_sum_full_3d *** 
     182      !! 
     183      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine (nomask) 
     184      !!---------------------------------------------------------------------- 
     185      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab 
     186      REAL(wp)                               ::   glob_sum_full_3d   ! global sum 
     187      !! 
     188      INTEGER    ::   ji, jj, jk   ! dummy loop indices 
     189      INTEGER    ::   ijpk ! local variables: size of ptab 
     190      !!----------------------------------------------------------------------- 
     191      ! 
     192      ijpk = SIZE(ptab,3) 
     193      ! 
     194      glob_sum_full_3d = 0.e0 
     195      DO jk = 1, ijpk 
     196         glob_sum_full_3d = glob_sum_full_3d + SUM( ptab(:,:,jk) * tmask_h(:,:) ) 
     197      END DO 
     198      IF( lk_mpp )   CALL mpp_sum( glob_sum_full_3d ) 
     199      ! 
     200   END FUNCTION glob_sum_full_3d 
     201 
    158202 
    159203#else   
    … …  
    314358   END FUNCTION glob_sum_3d_a    
    315359 
     360   FUNCTION glob_sum_full_2d( ptab ) 
     361      !!---------------------------------------------------------------------- 
     362      !!                  ***  FUNCTION  glob_sum_full_2d *** 
     363      !! 
     364      !! ** Purpose : perform a sum in calling DDPDD routine 
     365      !!---------------------------------------------------------------------- 
     366      REAL(wp), INTENT(in), DIMENSION(:,:) ::   ptab 
     367      REAL(wp)                             ::   glob_sum_full_2d   ! global sum (nomask) 
     368      !! 
     369      COMPLEX(wp)::   ctmp 
     370      REAL(wp)   ::   ztmp 
     371      INTEGER    ::   ji, jj   ! dummy loop indices 
     372      !!----------------------------------------------------------------------- 
     373      ! 
     374      ztmp = 0.e0 
     375      ctmp = CMPLX( 0.e0, 0.e0, wp ) 
     376      DO jj = 1, jpj 
     377         DO ji =1, jpi 
     378         ztmp =  ptab(ji,jj) * tmask_h(ji,jj)  
     379         CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     380         END DO 
     381      END DO 
     382      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain 
     383      glob_sum_full_2d = REAL(ctmp,wp) 
     384      ! 
     385   END FUNCTION glob_sum_full_2d 
     386 
     387   FUNCTION glob_sum_full_3d( ptab ) 
     388      !!---------------------------------------------------------------------- 
     389      !!                  ***  FUNCTION  glob_sum_full_3d *** 
     390      !! 
     391      !! ** Purpose : perform a sum on a 3D array in calling DDPDD routine 
     392      !!---------------------------------------------------------------------- 
     393      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   ptab 
     394      REAL(wp)                               ::   glob_sum_full_3d   ! global sum (nomask) 
     395      !! 
     396      COMPLEX(wp)::   ctmp 
     397      REAL(wp)   ::   ztmp 
     398      INTEGER    ::   ji, jj, jk   ! dummy loop indices 
     399      INTEGER    ::   ijpk ! local variables: size of ptab 
     400      !!----------------------------------------------------------------------- 
     401      ! 
     402      ijpk = SIZE(ptab,3) 
     403      ! 
     404      ztmp = 0.e0 
     405      ctmp = CMPLX( 0.e0, 0.e0, wp ) 
     406      DO jk = 1, ijpk 
     407         DO jj = 1, jpj 
     408            DO ji =1, jpi 
     409            ztmp =  ptab(ji,jj,jk) * tmask_h(ji,jj) 
     410            CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     411            END DO 
     412         END DO 
     413      END DO 
     414      IF( lk_mpp )   CALL mpp_sum( ctmp )   ! sum over the global domain 
     415      glob_sum_full_3d = REAL(ctmp,wp) 
     416      ! 
     417   END FUNCTION glob_sum_full_3d 
     418 
     419 
     420 
    316421#endif 
    317422 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r6060 r6069  
    6767   USE diadct         ! sections transports           (dia_dct_init routine) 
    6868   USE diaobs         ! Observation diagnostics       (dia_obs_init routine) 
     69   USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
    6970   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    7071   USE step           ! NEMO time-stepping                 (stp     routine) 
    … …  
    8182#endif 
    8283   USE lib_mpp        ! distributed memory computing 
     84   USE diurnal_bulk    ! diurnal bulk SST  
     85   USE step_diu        ! diurnal bulk SST timestepping (called from here if run offline) 
    8386#if defined key_iomput 
    8487   USE xios           ! xIOserver 
    … …  
    8790   USE lbcnfd , ONLY  : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges  
    8891   USE sbc_oce, ONLY  : lk_oasis 
     92   USE diatmb          ! Top,middle,bottom output 
     93   USE dia25h          ! 25h mean output 
    8994 
    9095   IMPLICIT NONE 
    … …  
    171176            CALL stp                         ! AGRIF: time stepping 
    172177#else 
    173             CALL stp( istp )                 ! standard time stepping 
     178            IF ( .NOT. ln_diurnal_only ) THEN  
     179               CALL stp( istp )                 ! standard time stepping  
     180            ELSE  
     181               CALL stp_diurnal( istp )        ! time step only the diurnal SST  
     182            ENDIF  
    174183#endif 
    175184            istp = istp + 1 
    … …  
    178187#endif 
    179188 
    180       IF( lk_diaobs   )   CALL dia_obs_wri 
     189      IF( ln_diaobs   )   CALL dia_obs_wri 
    181190      ! 
    182191      IF( ln_icebergs )   CALL icb_end( nitend ) 
    … …  
    193202      ! 
    194203#if defined key_agrif 
    195       IF(.NOT.Agrif_Root() ) THEN 
    196                                 CALL Agrif_ParentGrid_To_ChildGrid() 
    197          IF( lk_diaobs )        CALL dia_obs_wri 
     204      IF( .NOT. Agrif_Root() ) THEN 
     205                         CALL Agrif_ParentGrid_To_ChildGrid() 
     206         IF( ln_diaobs ) CALL dia_obs_wri 
    198207         IF( nn_timing == 1 )   CALL timing_finalize 
    199208                                CALL Agrif_ChildGrid_To_ParentGrid() 
    … …  
    231240      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   & 
    232241         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   & 
    233          &             nn_bench, nn_timing 
     242         &             nn_bench, nn_timing, nn_diacfl 
    234243      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    235244         &             jpizoom, jpjzoom, jperio, ln_use_jattr 
    … …  
    398407      IF( ln_nnogather )    CALL nemo_northcomms! northfold neighbour lists (must be done after the masks are defined) 
    399408      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
     409       
     410      CALL diurnal_sst_bulk_init            ! diurnal sst 
     411      IF ( ln_diurnal ) CALL diurnal_sst_coolskin_init   ! cool skin    
     412       
     413      ! IF ln_diurnal_only, then we only want a subset of the initialisation routines 
     414      IF ( ln_diurnal_only ) THEN 
     415         CALL  istate_init   ! ocean initial state (Dynamics and tracers) 
     416         CALL     sbc_init   ! Forcings : surface module 
     417         CALL tra_qsr_init   ! penetrative solar radiation qsr 
     418         IF( ln_diaobs     ) THEN                  ! Observation & model comparison 
     419            CALL dia_obs_init            ! Initialize observational data 
     420            CALL dia_obs( nit000 - 1 )   ! Observation operator for restart 
     421         ENDIF      
     422         !                                     ! Assimilation increments 
     423         IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments 
     424                  
     425         IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 
     426         RETURN 
     427      ENDIF 
     428       
    400429                            CALL  istate_init   ! ocean initial state (Dynamics and tracers) 
    401430 
    … …  
    458487      !                                      ! Diagnostics 
    459488      IF( lk_floats     )   CALL     flo_init   ! drifting Floats 
     489                            CALL dia_cfl_init   ! Initialise CFL diagnostics 
    460490      IF( lk_diaar5     )   CALL dia_ar5_init   ! ar5 diag 
    461491                            CALL dia_ptr_init   ! Poleward TRansports initialization 
    … …  
    463493                            CALL dia_hsb_init   ! heat content, salt content and volume budgets 
    464494                            CALL     trd_init   ! Mixed-layer/Vorticity/Integral constraints trends 
    465       IF( lk_diaobs     ) THEN                  ! Observation & model comparison 
    466495                            CALL dia_obs_init            ! Initialize observational data 
    467                             CALL dia_obs( nit000 - 1 )   ! Observation operator for restart 
    468       ENDIF 
    469       !                                      ! Assimilation increments 
     496      IF( ln_diaobs     )   CALL dia_obs( nit000 - 1 )   ! Observation operator for restart 
     497 
     498      !                                         ! Assimilation increments 
    470499      IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments 
    471500      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 
     501                            CALL dia_tmb_init  ! TMB outputs 
     502                            CALL dia_25h_init  ! 25h mean  outputs 
     503 
    472504      ! 
    473505   END SUBROUTINE nemo_init 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/oce.F90

    r6060 r6069  
    5555   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gtsu, gtsv   !: horizontal gradient of T, S bottom u-point  
    5656   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   gru , grv    !: horizontal gradient of rd at bottom u-point 
    57    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   aru , arv     
    58    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   gzu , gzv     
    59    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ge3ru, ge3rv   !: horizontal gradient of T, S and rd at top v-point   
    6057 
    6158   !! (ISF) interpolated gradient (only used for ice shelf case)  
    … …  
    6360   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gtui, gtvi   !: horizontal gradient of T, S and rd at top u-point  
    6461   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   grui, grvi   !: horizontal gradient of T, S and rd at top v-point   
    65    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   arui, arvi   !: horizontal average  of rd          at top v-point   
    66    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   gzui, gzvi   !: horizontal gradient of z           at top v-point   
    67    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ge3rui, ge3rvi   !: horizontal gradient of T, S and rd at top v-point   
    6862   !! (ISF) ice load 
    6963   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   riceload 
    … …  
    111105         &     spgu  (jpi,jpj)   , spgv(jpi,jpj)   ,                       & 
    112106         &     gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts),                     & 
    113          &     aru(jpi,jpj)      , arv(jpi,jpj)      ,                     & 
    114          &     gzu(jpi,jpj)      , gzv(jpi,jpj)      ,                     & 
    115107         &     gru(jpi,jpj)      , grv(jpi,jpj)      ,                     & 
    116          &     ge3ru(jpi,jpj)    , ge3rv(jpi,jpj)    ,                     & 
    117108         &     gtui(jpi,jpj,jpts), gtvi(jpi,jpj,jpts),                     & 
    118          &     arui(jpi,jpj)     , arvi(jpi,jpj)     ,                     & 
    119          &     gzui(jpi,jpj)     , gzvi(jpi,jpj)     ,                     & 
    120          &     ge3rui(jpi,jpj)   , ge3rvi(jpi,jpj)   ,                     & 
    121109         &     grui(jpi,jpj)     , grvi(jpi,jpj)     ,                     & 
    122110         &     riceload(jpi,jpj),                             STAT=ierr(2) ) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/step.F90

    r6060 r6069  
    164164 
    165165         IF( ln_zps .AND.       ln_isfcav)                               & 
    166             &            CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv, gtui, gtvi,   &    ! Partial steps for top cell (ISF) 
    167             &                                          rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
    168             &                                   grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) ! of t, s, rd at the first ocean level 
    169  
     166            &            CALL zps_hde_isf( kstp, jpts, tsb, gtsu, gtsv, gtui, gtvi,  &  ! Partial steps for top cell (ISF) 
     167            &                                          rhd, gru , grv , grui, grvi   )  ! of t, s, rd at the first ocean level 
    170168         IF( ln_traldf_triad ) THEN  
    171169                         CALL ldf_slp_triad( kstp )                       ! before slope for triad operator 
    … …  
    184182      IF(.NOT.ln_linssh )   CALL dom_vvl_sf_nxt( kstp )  ! after vertical scale factors  
    185183                            CALL wzv           ( kstp )  ! now cross-level velocity  
    186  
    187184!!gm : why also here ???? 
    188185      IF( ln_sto_eos    )   CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    … …  
    194191!!                                         but ensures reproductible results 
    195192!!                                         with previous versions using split-explicit free surface           
    196             IF( ln_zps .AND. .NOT. ln_isfcav)   &                           ! Partial steps: bottom before horizontal gradient 
    197                &            CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,  &  ! of t, s, rd at the last ocean level 
    198                &                                          rhd, gru , grv    ) 
    199             IF( ln_zps .AND.       ln_isfcav)   &                           ! Partial steps: top & bottom before horizontal gradient 
    200                &            CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, gtui, gtvi,   &  
    201                &                                          rhd, gru , grv , aru , arv , gzu , gzv , ge3ru , ge3rv ,   & 
    202                &                                               grui, grvi, arui, arvi, gzui, gzvi, ge3rui, ge3rvi    ) 
     193            IF( ln_zps .AND. .NOT. ln_isfcav )                               & 
     194               &            CALL zps_hde    ( kstp, jpts, tsn, gtsu, gtsv,   &  ! Partial steps: before horizontal gradient 
     195               &                                          rhd, gru , grv     )  ! of t, s, rd at the last ocean level 
     196            IF( ln_zps .AND.       ln_isfcav )                                          & 
     197               &            CALL zps_hde_isf( kstp, jpts, tsn, gtsu, gtsv, gtui, gtvi,  &  ! Partial steps for top cell (ISF) 
     198               &                                          rhd, gru , grv , grui, grvi   )  ! of t, s, rd at the first ocean level 
    203199!!jc: fs simplification 
    204200                             
    … …  
    230226 
    231227      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    232       ! diagnostics and outputs              
    233       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    234       IF( lk_floats  )   CALL flo_stp       ( kstp )  ! drifting Floats 
    235       IF( lk_diahth  )   CALL dia_hth       ( kstp )  ! Thermocline depth (20 degres isotherm depth) 
    236       IF(.NOT.ln_cpl )   CALL dia_fwb       ( kstp )  ! Fresh water budget diagnostics 
    237       IF( lk_diadct  )   CALL dia_dct       ( kstp )  ! Transports 
    238       IF( lk_diaar5  )   CALL dia_ar5       ( kstp )  ! ar5 diag 
    239       IF( lk_diaharm )   CALL dia_harm      ( kstp )  ! Tidal harmonic analysis 
    240                          CALL dia_wri       ( kstp )  ! ocean model: outputs 
     228      ! cool skin 
     229      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     230      IF ( ln_diurnal )  CALL stp_diurnal( kstp ) 
     231       
     232      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     233      ! diagnostics and outputs             (ua, va, tsa used as workspace) 
     234      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     235      IF( lk_floats  )   CALL flo_stp( kstp )         ! drifting Floats 
     236      IF( nn_diacfl == 1 )   CALL dia_cfl( kstp )         ! Courant number diagnostics 
     237      IF( lk_diahth  )   CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
     238      IF(.NOT.ln_cpl )   CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
     239      IF( lk_diadct  )   CALL dia_dct( kstp )         ! Transports 
     240      IF( lk_diaar5  )   CALL dia_ar5( kstp )         ! ar5 diag 
     241      IF( lk_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis 
     242                         CALL dia_wri( kstp )         ! ocean model: outputs 
    241243      ! 
    242244      IF( ln_crs     )   CALL crs_fld       ( kstp )  ! ocean model: online field coarsening & output 
    243  
     245       
    244246#if defined key_top 
    245247      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    317319      ENDIF 
    318320#endif 
    319       IF( ln_diahsb  )   CALL dia_hsb       ( kstp )  ! - ML - global conservation diagnostics 
    320       IF( lk_diaobs  )   CALL dia_obs       ( kstp )  ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
     321      IF( ln_diahsb  )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
     322      IF( ln_diaobs  )   CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    321323 
    322324      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    351353      ! 
    352354   END SUBROUTINE stp 
    353  
    354    !!====================================================================== 
     355    
    355356END MODULE step 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r5930 r6069  
    7272   USE zdfmxl           ! Mixed-layer depth                (zdf_mxl routine) 
    7373 
     74   USE step_diu        ! Time stepping for diurnal sst 
     75   USE diurnal_bulk    ! diurnal SST bulk routines  (diurnal_sst_takaya routine)  
     76   USE cool_skin       ! diurnal cool skin correction (diurnal_sst_coolskin routine)    
     77   USE sbc_oce         ! surface fluxes   
     78    
    7479   USE zpshde           ! partial step: hor. derivative     (zps_hde routine) 
    7580 
    … …  
    8287   USE diahsb           ! heat, salt and volume budgets    (dia_hsb routine) 
    8388   USE diaharm 
     89   USE diacfl 
    8490   USE flo_oce          ! floats variables 
    8591   USE floats           ! floats computation               (flo_stp routine) 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r5510 r6069  
    184184      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   & 
    185185         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   & 
    186          &             nn_bench, nn_timing 
     186         &             nn_bench, nn_timing, nn_diacfl 
    187187      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, & 
    188188         &             jpizoom, jpjzoom, jperio, ln_use_jattr 

  • branches/2015/dev_merge_2015/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r6060 r6069  
    244244   END SUBROUTINE trc_ini_state 
    245245 
    246  
    247246   SUBROUTINE top_alloc 
    248247      !!---------------------------------------------------------------------- 
Note: See TracChangeset for help on using the changeset viewer.