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

Changeset 7367


Ignore:
Timestamp:
2016-11-29T11:52:31+01:00 (7 years ago)
Author:
deazer
Message:

Contains merged code for CO5 reference.

Location:
branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC
Files:
14 added
94 edited

Legend:

Unmodified
Added
Removed

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

    r7363 r7367  
    1010   !!   NEMO     3.3  ! 2010-05  (D. Lea)  Update to work with NEMO v3.2 
    1111   !!             -   ! 2010-05  (D. Lea)  add calc_month_len routine based on day_init  
     12   !!            3.4  ! 2012-10  (A. Weaver and K. Mogensen) Fix for direct initialization 
    1213   !!---------------------------------------------------------------------- 
    1314 
    … …  
    2021   !!   dyn_asm_inc  : Apply the dynamic (u and v) increments 
    2122   !!   ssh_asm_inc  : Apply the SSH increment 
     23   !!   seaice_asm_inc  : Apply the seaice increment 
    2224   !!---------------------------------------------------------------------- 
    2325   USE wrk_nemo         ! Memory Allocation 
    … …  
    2527   USE dom_oce          ! Ocean space and time domain 
    2628   USE oce              ! Dynamics and active tracers defined in memory 
    27    USE divcur           ! Horizontal divergence and relative vorticity 
    2829   USE ldfdyn_oce       ! ocean dynamics: lateral physics 
    2930   USE eosbn2           ! Equation of state - in situ and potential density 
    … …  
    3334   USE c1d              ! 1D initialization 
    3435   USE in_out_manager   ! I/O manager 
    35    USE lib_mpp           ! MPP library 
     36   USE lib_mpp          ! MPP library 
     37#if defined key_lim3 || defined key_lim2 || defined key_cice 
     38#if defined key_lim3  
     39   USE ice_3, ONLY : &               ! LIM Ice model variables  () 
     40      & frld, pfrld, hicif, hsnif, phicif 
     41   USE sbc_oce, ONLY : & 
     42      & fr_i                         ! ice fraction 
     43#endif 
     44#if defined key_lim2 
     45   USE ice_2, ONLY : &               ! LIM Ice model variables 
     46      & frld, pfrld, hicif, hsnif, phicif 
     47   USE sbc_oce, ONLY : & 
     48      & fr_i                         ! ice fraction 
     49#endif 
     50#if defined key_cice 
     51   USE sbc_oce, ONLY : & 
     52      & fr_i                          ! ice fraction 
     53   USE sbc_ice, ONLY : &             ! CICE Ice model variables 
     54      & naicet, ndaice_da, nfresh_da, nfsalt_da, nTf  
     55   USE ice_constants, only: Lfresh, rhoi,rhos        ! for updating ice and snow enthalphy 
     56!   USE ice_therm_itd, only: hfrazilmin               ! thickness at new ice points 
     57   USE ice_domain_size, only: ncat,ntilyr,ntslyr 
     58#endif 
     59   USE phycst, ONLY : &              ! Physical Ice variables 
     60      & soce, sice, rhoic, rhosn, rday 
     61#endif 
     62   USE sbc_oce          ! Surface boundary condition variables. 
     63    
     64   USE eosbn2, only: tfreez  
     65   
     66   USE zdfmxl, ONLY :  &   
     67   &  hmld_tref,       &    
     68#if defined key_karaml 
     69   &  hmld_kara,       & 
     70#endif    
     71   &  hmld,            &  
     72   &  hmlp 
     73  
     74#if defined key_bdy  
     75   USE bdy_oce, ONLY: bdytmask   
     76#endif   
     77   USE histcom 
    3678 
    3779   IMPLICIT NONE 
    … …  
    4385   PUBLIC   dyn_asm_inc    !: Apply the dynamic (u and v) increments 
    4486   PUBLIC   ssh_asm_inc    !: Apply the SSH increment 
     87   PUBLIC   seaice_asm_inc !: Apply the seaice increment 
    4588 
    4689#if defined key_asminc 
    … …  
    5699   LOGICAL, PUBLIC :: ln_dyninc = .FALSE. !: No dynamics (u and v) assimilation increments 
    57100   LOGICAL, PUBLIC :: ln_sshinc = .FALSE. !: No sea surface height assimilation increment 
     101   LOGICAL, PUBLIC :: ln_seaiceinc = .FALSE. !: No sea ice concentration increment 
    58102   LOGICAL, PUBLIC :: ln_salfix = .FALSE. !: Apply minimum salinity check 
     103   LOGICAL, PUBLIC :: ln_temnofreeze = .FALSE. !: Don't allow the temperature to drop below freezing 
    59104   INTEGER, PUBLIC :: nn_divdmp = 0       !: Apply divergence damping filter nn_divdmp times 
    60105 
    … …  
    78123 
    79124   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ssh_bkg, ssh_bkginc   ! Background sea surface height and its increment 
    80  
     125   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   seaice_bkginc         ! Increment to the background sea ice conc 
     126    
     127  INTEGER :: mld_choice = 4     !: choice of mld criteria to use                   
     128                             !: 1) turbocline depth   
     129                             !: 2) surface to 0.001 kg/m^3 change   
     130                             !: 3) Kara MLD   
     131                             !: 4) Temperature criteria.                                 
     132                                  
    81133   !! * Substitutions 
    82134#  include "domzgr_substitute.h90" 
    … …  
    122174      REAL(wp) :: zdate_bkg    ! Date in background state file for DI 
    123175      REAL(wp) :: zdate_inc    ! Time axis in increments file 
    124  
     176       
     177      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: &  
     178          &       t_bkginc_2d  !file for reading in 2D   
     179                               !temperature increments  
     180      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: &  
     181          &       z_mld     !Mixed layer depth  
     182           
    125183      REAL(wp), POINTER, DIMENSION(:,:) :: hdiv 
     184             
    126185      !! 
    127186      NAMELIST/nam_asminc/ ln_bkgwri, ln_trjwri,                           & 
    … …  
    130189         &                 nitbkg, nitdin, nitiaustr, nitiaufin, niaufn,   & 
    131190         &                 nittrjfrq, ln_salfix, salfixmin,                & 
    132          &                 nn_divdmp 
     191         &                 nn_divdmp, mld_choice 
    133192      !!---------------------------------------------------------------------- 
    134193 
    … …  
    143202      ln_dyninc = .FALSE. 
    144203      ln_sshinc = .FALSE. 
     204      ln_seaiceinc = .FALSE. 
    145205      ln_asmdin = .FALSE. 
    146206      ln_asmiau = .TRUE. 
    147207      ln_salfix = .FALSE. 
     208      ln_temnofreeze = .FALSE. 
    148209      salfixmin = -9999 
    149210      nitbkg    = 0 
    … …  
    156217      REWIND ( numnam ) 
    157218      READ   ( numnam, nam_asminc ) 
    158  
     219      
     220      ! Set the data time for diagnostics to the end of the IAU period   
     221      ! and multiply by the timestep to get seconds from start of run  
     222      data_time = rdt * nitiaufin  
     223        
     224      IF( ln_sco .AND. (ln_sshinc .OR. ln_seaiceinc .OR. ln_asmdin &  
     225         &              .OR. ln_dyninc ) )THEN  
     226         CALL ctl_warn("Only SST assimilation currently supported in "//&  
     227         &              "s-coordinates")  
     228         ln_sshinc = .FALSE.  
     229         ln_seaiceinc = .FALSE.  
     230         ln_asmdin = .FALSE.  
     231         ln_dyninc = .FALSE.  
     232      ENDIF  
     233       
    159234      ! Control print 
    160235      IF(lwp) THEN 
    … …  
    169244         WRITE(numout,*) '      Logical switch for applying SSH increments               ln_sshinc = ', ln_sshinc 
    170245         WRITE(numout,*) '      Logical switch for Direct Initialization (DI)            ln_asmdin = ', ln_asmdin 
     246         WRITE(numout,*) '      Logical switch for applying sea ice increments        ln_seaiceinc = ', ln_seaiceinc 
    171247         WRITE(numout,*) '      Logical switch for Incremental Analysis Updating (IAU)   ln_asmiau = ', ln_asmiau 
    172248         WRITE(numout,*) '      Timestep of background in [0,nitend-nit000-1]            nitbkg    = ', nitbkg 
    … …  
    235311 
    236312      IF (      ( ( .NOT. ln_asmdin ).AND.( .NOT. ln_asmiau ) ) & 
    237            .AND.( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) ) ) & 
    238          & CALL ctl_stop( ' One or more of ln_trainc, ln_dyninc and ln_sshinc is set to .true.', & 
     313           .AND.( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) .OR. ( ln_seaiceinc) )) & 
     314         & CALL ctl_stop( ' One or more of ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc is set to .true.', & 
    239315         &                ' but ln_asmdin and ln_asmiau are both set to .false. :', & 
    240316         &                ' Inconsistent options') 
    … …  
    248324         &                ' Type IAU weighting function is invalid') 
    249325 
    250       IF ( ( .NOT. ln_trainc ).AND.( .NOT. ln_dyninc ).AND.( .NOT. ln_sshinc ) & 
     326      IF ( ( .NOT. ln_trainc ).AND.( .NOT. ln_dyninc ).AND.( .NOT. ln_sshinc ).AND.( .NOT. ln_seaiceinc ) & 
    251327         &                     )  & 
    252          & CALL ctl_warn( ' ln_trainc, ln_dyninc and ln_sshinc are set to .false. :', & 
     328         & CALL ctl_warn( ' ln_trainc, ln_dyninc, ln_sshinc and ln_seaiceinc are set to .false. :', & 
    253329         &                ' The assimilation increments are not applied') 
    254330 
    … …  
    353429      ALLOCATE( v_bkginc(jpi,jpj,jpk) ) 
    354430      ALLOCATE( ssh_bkginc(jpi,jpj)   ) 
     431      ALLOCATE( seaice_bkginc(jpi,jpj)) 
    355432#if defined key_asminc 
    356433      ALLOCATE( ssh_iau(jpi,jpj)      ) 
    … …  
    361438      v_bkginc(:,:,:) = 0.0 
    362439      ssh_bkginc(:,:) = 0.0 
     440      seaice_bkginc(:,:) = 0.0 
    363441#if defined key_asminc 
    364442      ssh_iau(:,:)    = 0.0 
    365443#endif 
    366       IF ( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ) ) THEN 
     444      IF ( ( ln_trainc ).OR.( ln_dyninc ).OR.( ln_sshinc ).OR.( ln_seaiceinc ) ) THEN 
    367445 
    368446         !-------------------------------------------------------------------- 
    … …  
    397475 
    398476         IF ( ln_trainc ) THEN    
    399             CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 ) 
    400             CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 ) 
    401             ! Apply the masks 
    402             t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:) 
    403             s_bkginc(:,:,:) = s_bkginc(:,:,:) * tmask(:,:,:) 
    404             ! Set missing increments to 0.0 rather than 1e+20 
    405             ! to allow for differences in masks 
    406             WHERE( ABS( t_bkginc(:,:,:) ) > 1.0e+10 ) t_bkginc(:,:,:) = 0.0 
    407             WHERE( ABS( s_bkginc(:,:,:) ) > 1.0e+10 ) s_bkginc(:,:,:) = 0.0 
     477             
     478            IF (ln_sco) THEN  
     479                 
     480               ALLOCATE(z_mld(jpi,jpj))  
     481               SELECT CASE(mld_choice)  
     482               CASE(1)  
     483                  z_mld = hmld  
     484               CASE(2)  
     485                  z_mld = hmlp  
     486               CASE(3)  
     487#if defined key_karaml 
     488                  z_mld = hmld_kara 
     489#endif 
     490                  CALL ctl_stop("Kara mixed layer not defined in current version of NEMO")  ! JW: Safty feature, should be removed 
     491                                                                                            ! once the kara mixed layer is availible  
     492               CASE(4)  
     493                  z_mld = hmld_tref  
     494               END SELECT        
     495                       
     496               ALLOCATE( t_bkginc_2d(jpi,jpj) )  
     497               CALL iom_get( inum, jpdom_autoglo, 'bckinsurft', t_bkginc_2d, 1)  
     498#if defined key_bdy                 
     499               DO jk = 1,jpkm1  
     500                  WHERE( z_mld(:,:) > fsdepw(:,:,jk) )  
     501                     t_bkginc(:,:,jk) = t_bkginc_2d(:,:) * bdytmask(:,:)  
     502                  ELSEWHERE  
     503                     t_bkginc(:,:,jk) = 0.  
     504                  ENDWHERE  
     505               ENDDO  
     506#else  
     507               t_bkginc(:,:,:) = 0.  
     508#endif                 
     509               s_bkginc(:,:,:) = 0.  
     510                 
     511               !DEALLOCATE temporary arrays  
     512               DEALLOCATE(z_mld, t_bkginc_2d)  
     513             
     514            ELSE  
     515                
     516               CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 ) 
     517               CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 ) 
     518               ! Apply the masks 
     519               t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:) 
     520               s_bkginc(:,:,:) = s_bkginc(:,:,:) * tmask(:,:,:) 
     521               ! Set missing increments to 0.0 rather than 1e+20 
     522               ! to allow for differences in masks 
     523               WHERE( ABS( t_bkginc(:,:,:) ) > 1.0e+10 ) t_bkginc(:,:,:) = 0.0 
     524               WHERE( ABS( s_bkginc(:,:,:) ) > 1.0e+10 ) s_bkginc(:,:,:) = 0.0 
     525          
     526            ENDIF 
     527          
    408528         ENDIF 
    409529 
    … …  
    429549         ENDIF 
    430550 
     551         IF ( ln_seaiceinc ) THEN 
     552            CALL iom_get( inum, jpdom_autoglo, 'bckinseaice', seaice_bkginc, 1 ) 
     553            ! Apply the masks 
     554            seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1) 
     555            ! Set missing increments to 0.0 rather than 1e+20 
     556            ! to allow for differences in masks 
     557            WHERE( ABS( seaice_bkginc(:,:) ) > 1.0e+10 ) seaice_bkginc(:,:) = 0.0 
     558         ENDIF 
     559 
    431560         CALL iom_close( inum ) 
    432561  
    … …  
    437566      !----------------------------------------------------------------------- 
    438567 
    439  
    440568      IF ( ln_dyninc .AND. nn_divdmp > 0 ) THEN 
    441569 
    442       CALL wrk_alloc(jpi,jpj,hdiv)  
    443  
    444        DO  jt = 1, nn_divdmp 
    445  
    446            DO jk = 1, jpkm1 
    447  
    448                   hdiv(:,:) = 0._wp 
    449  
    450             DO jj = 2, jpjm1 
    451                DO ji = fs_2, fs_jpim1   ! vector opt. 
    452                   hdiv(ji,jj) =   & 
    453                      (  e2u(ji  ,jj)*fse3u(ji  ,jj,jk) * u_bkginc(ji  ,jj,jk)       & 
    454                       - e2u(ji-1,jj)*fse3u(ji-1,jj,jk) * u_bkginc(ji-1,jj,jk)       & 
    455                       + e1v(ji,jj  )*fse3v(ji,jj  ,jk) * v_bkginc(ji,jj  ,jk)       & 
    456                       - e1v(ji,jj-1)*fse3v(ji,jj-1,jk) * v_bkginc(ji,jj-1,jk)  )    & 
    457                       / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     570         CALL wrk_alloc(jpi,jpj,hdiv)  
     571 
     572         DO  jt = 1, nn_divdmp 
     573 
     574            DO jk = 1, jpkm1 
     575 
     576               hdiv(:,:) = 0._wp 
     577 
     578               DO jj = 2, jpjm1 
     579                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     580                     hdiv(ji,jj) =   & 
     581                        (  e2u(ji  ,jj  ) * fse3u(ji  ,jj  ,jk) * u_bkginc(ji  ,jj  ,jk)     & 
     582                         - e2u(ji-1,jj  ) * fse3u(ji-1,jj  ,jk) * u_bkginc(ji-1,jj  ,jk)     & 
     583                         + e1v(ji  ,jj  ) * fse3v(ji  ,jj  ,jk) * v_bkginc(ji  ,jj  ,jk)     & 
     584                         - e1v(ji  ,jj-1) * fse3v(ji  ,jj-1,jk) * v_bkginc(ji  ,jj-1,jk)  )  & 
     585                         / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     586                  END DO 
    458587               END DO 
     588 
     589               CALL lbc_lnk( hdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
     590 
     591               DO jj = 2, jpjm1 
     592                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     593                     u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) + 0.2_wp * ( e1t(ji+1,jj)*e2t(ji+1,jj) * hdiv(ji+1,jj)   & 
     594                                                                        - e1t(ji  ,jj)*e2t(ji  ,jj) * hdiv(ji  ,jj) ) & 
     595                                                                      / e1u(ji,jj) * umask(ji,jj,jk)  
     596                     v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk) + 0.2_wp * ( e1t(ji,jj+1)*e2t(ji,jj+1) * hdiv(ji,jj+1)   & 
     597                                                                        - e1t(ji,jj  )*e2t(ji,jj  ) * hdiv(ji,jj  ) ) & 
     598                                                                      / e2v(ji,jj) * vmask(ji,jj,jk)  
     599                  END DO 
     600               END DO 
     601 
    459602            END DO 
    460603 
    461             CALL lbc_lnk( hdiv, 'T', 1. )   ! lateral boundary cond. (no sign change) 
    462  
    463             DO jj = 2, jpjm1 
    464                DO ji = fs_2, fs_jpim1   ! vector opt. 
    465                   u_bkginc(ji,jj,jk) = u_bkginc(ji,jj,jk) + 0.2 * ( e1t(ji+1,jj)*e2t(ji+1,jj) * hdiv(ji+1,jj)   & 
    466                                                                   - e1t(ji  ,jj)*e2t(ji  ,jj) * hdiv(ji  ,jj) ) & 
    467                                                                 / e1u(ji,jj) * umask(ji,jj,jk)  
    468                   v_bkginc(ji,jj,jk) = v_bkginc(ji,jj,jk) + 0.2 * ( e1t(ji,jj+1)*e2t(ji,jj+1) * hdiv(ji,jj+1)   & 
    469                                                                   - e1t(ji,jj  )*e2t(ji,jj  ) * hdiv(ji,jj  ) ) & 
    470                                                                 / e2v(ji,jj) * vmask(ji,jj,jk)  
    471                END DO 
    472             END DO 
    473  
    474            END DO 
    475  
    476        END DO 
    477  
    478        CALL wrk_dealloc(jpi,jpj,hdiv)  
     604         END DO 
     605 
     606         CALL wrk_dealloc(jpi,jpj,hdiv)  
    479607 
    480608      ENDIF 
    … …  
    506634         CALL iom_open( c_asmdin, inum ) 
    507635 
    508          CALL iom_get( inum, 'zdate', zdate_bkg )  
     636         CALL iom_get( inum, 'rdastp', zdate_bkg )  
    509637         
    510638         IF(lwp) THEN 
    … …  
    662790      INTEGER :: it 
    663791      REAL(wp) :: zincwgt  ! IAU weight for current time step 
    664       !!---------------------------------------------------------------------- 
     792      REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d freezing point values 
     793      !!---------------------------------------------------------------------- 
     794 
     795      ! freezing point calculation taken from oc_fz_pt (but calculated for all depths)  
     796      ! used to prevent the applied increments taking the temperature below the local freezing point  
     797 
     798      ! Note:  For NEMO/CICE this will be identical to nTf (for the surface), but defined at the now point.  
     799  
     800      DO jk=1, jpkm1  
     801         fzptnz (:,:,jk) = tfreez(tsn(:,:,jk,jp_sal )) - 7.53e-4_wp * fsdepw(:,:,jk)  
     802      ENDDO  
    665803 
    666804      IF ( ln_asmiau ) THEN 
    … …  
    684822            ! Update the tracer tendencies 
    685823            DO jk = 1, jpkm1 
    686                tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt   
    687                tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt 
     824               IF (ln_temnofreeze) THEN 
     825                  ! Do not apply negative increments if the temperature will fall below freezing 
     826                  WHERE(t_bkginc(:,:,jk) > 0.0_wp .OR. & 
     827                     &   tsn(:,:,jk,jp_tem) + tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) )  
     828                     tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt   
     829                  END WHERE 
     830               ELSE 
     831                  tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt   
     832               ENDIF 
     833               IF (ln_salfix) THEN 
     834                  ! Do not apply negative increments if the salinity will fall below a specified 
     835                  ! minimum value salfixmin 
     836                  WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. & 
     837                     &   tsn(:,:,jk,jp_sal) + tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin )  
     838                     tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt 
     839                  END WHERE 
     840               ELSE 
     841                  tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt 
     842               ENDIF 
    688843            END DO 
    689  
    690             ! Salinity fix 
    691             IF (ln_salfix) THEN 
    692                DO jk = 1, jpkm1 
    693                   DO jj = 1, jpj 
    694                      DO ji= 1, jpi 
    695                         tsa(ji,jj,jk,jp_sal) = MAX( tsa(ji,jj,jk,jp_sal), salfixmin ) 
    696                      END DO 
    697                   END DO 
    698                END DO 
    699             ENDIF 
    700844 
    701845         ENDIF 
    … …  
    718862 
    719863            ! Initialize the now fields with the background + increment 
    720             tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
    721             tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
    722  
    723             ! Optional salinity fix 
     864            IF (ln_temnofreeze) THEN 
     865               ! Do not apply negative increments if the temperature will fall below freezing 
     866               WHERE(t_bkginc(:,:,:) > 0.0_wp .OR. & 
     867                  &   tsn(:,:,:,jp_tem) + t_bkginc(:,:,:) > fzptnz(:,:,:) )  
     868                  tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
     869               END WHERE 
     870            ELSE 
     871               tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
     872            ENDIF 
    724873            IF (ln_salfix) THEN 
    725                DO jk = 1, jpkm1 
    726                   DO jj = 1, jpj 
    727                      DO ji= 1, jpi 
    728                         tsn(ji,jj,jk,jp_sal) = MAX( tsn(ji,jj,jk,jp_sal), salfixmin ) 
    729                      END DO 
    730                   END DO 
    731                END DO 
     874               ! Do not apply negative increments if the salinity will fall below a specified 
     875               ! minimum value salfixmin 
     876               WHERE(s_bkginc(:,:,:) > 0.0_wp .OR. & 
     877                  &   tsn(:,:,:,jp_sal) + s_bkginc(:,:,:) > salfixmin )  
     878                  tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
     879               END WHERE 
     880            ELSE 
     881               tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
    732882            ENDIF 
    733883 
    734             tsb(:,:,:,:) = tsn(:,:,:,:)                        ! Update before fields 
     884            tsb(:,:,:,:) = tsn(:,:,:,:)               ! Update before fields 
    735885 
    736886            CALL eos( tsb, rhd, rhop )                ! Before potential and in situ densities 
    737887          
    738888            IF( ln_zps .AND. .NOT. lk_c1d ) & 
    739                &  CALL zps_hde( nit000, jpts, tsb,   &  ! Partial steps: before horizontal derivative 
    740                &                gtsu, gtsv, rhd,        &  ! of T, S, rd at the bottom ocean level 
     889               &  CALL zps_hde( nit000, jpts, tsb, &  ! Partial steps: before horizontal derivative 
     890               &                gtsu, gtsv, rhd,   &  ! of T, S, rd at the bottom ocean level 
    741891               &                gru , grv ) 
     892 
     893#if defined key_zdfkpp 
     894            CALL eos( tsn, rhd )                      ! Compute rhd 
     895#endif 
    742896 
    743897            DEALLOCATE( t_bkginc ) 
    … …  
    748902         !   
    749903      ENDIF 
     904      ! Perhaps the following call should be in step 
     905      IF   ( ln_seaiceinc  )   CALL seaice_asm_inc ( kt )   ! apply sea ice concentration increment 
    750906      ! 
    751907   END SUBROUTINE tra_asm_inc 
    … …  
    817973            vb(:,:,:) = vn(:,:,:) 
    818974  
    819             CALL div_cur( kt )            ! Compute divergence and curl for now fields 
    820  
    821             rotb (:,:,:) = rotn (:,:,:)   ! Update before fields 
    822             hdivb(:,:,:) = hdivn(:,:,:) 
    823  
    824975            DEALLOCATE( u_bkg    ) 
    825976            DEALLOCATE( v_bkg    ) 
    … …  
    846997      ! 
    847998      INTEGER :: it 
     999      INTEGER :: jk 
    8481000      REAL(wp) :: zincwgt  ! IAU weight for current time step 
    8491001      !!---------------------------------------------------------------------- 
    … …  
    8911043            sshn(:,:) = ssh_bkg(:,:) + ssh_bkginc(:,:)   
    8921044 
    893             sshb(:,:) = sshn(:,:)         ! Update before fields 
     1045            ! Update before fields 
     1046            sshb(:,:) = sshn(:,:) 
    8941047 
    8951048            DEALLOCATE( ssh_bkg    ) 
    … …  
    9021055   END SUBROUTINE ssh_asm_inc 
    9031056 
     1057   SUBROUTINE seaice_asm_inc( kt, kindic ) 
     1058      !!---------------------------------------------------------------------- 
     1059      !!                    ***  ROUTINE seaice_asm_inc  *** 
     1060      !!           
     1061      !! ** Purpose : Apply the sea ice assimilation increment. 
     1062      !! 
     1063      !! ** Method  : Direct initialization or Incremental Analysis Updating. 
     1064      !! 
     1065      !! ** Action  :  
     1066      !! 
     1067      !! History : 
     1068      !!        !  07-2011  (D. Lea)  Initial version based on ssh_asm_inc 
     1069      !!---------------------------------------------------------------------- 
     1070 
     1071      IMPLICIT NONE 
     1072 
     1073      !! * Arguments 
     1074      INTEGER, INTENT(IN) :: kt   ! Current time step 
     1075      INTEGER, OPTIONAL, INTENT(IN) :: kindic ! flag for disabling the deallocation 
     1076 
     1077      !! * Local declarations 
     1078      INTEGER :: it 
     1079      REAL(wp) :: zincwgt  ! IAU weight for current time step 
     1080 
     1081#if defined key_lim3 || defined key_lim2 
     1082      REAL(wp), DIMENSION(jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc  ! LIM 
     1083      REAL(wp) :: zhicifmin=0.5_wp      ! ice minimum depth in metres 
     1084 
     1085#endif 
     1086 
     1087 
     1088      IF ( ln_asmiau ) THEN 
     1089 
     1090         !-------------------------------------------------------------------- 
     1091         ! Incremental Analysis Updating 
     1092         !-------------------------------------------------------------------- 
     1093 
     1094         IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN 
     1095 
     1096            it = kt - nit000 + 1 
     1097            zincwgt = wgtiau(it)      ! IAU weight for the current time step  
     1098            ! note this is not a tendency so should not be divided by rdt (as with the tracer and other increments) 
     1099 
     1100            IF(lwp) THEN 
     1101               WRITE(numout,*)  
     1102               WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', & 
     1103                  &  kt,' with IAU weight = ', wgtiau(it) 
     1104               WRITE(numout,*) '~~~~~~~~~~~~' 
     1105            ENDIF 
     1106 
     1107#if defined key_lim3 || defined key_lim2 
     1108 
     1109            zofrld(:,:)=frld(:,:) 
     1110            zohicif(:,:)=hicif(:,:) 
     1111 
     1112            frld = MIN( MAX( frld(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
     1113            pfrld = MIN( MAX( pfrld(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
     1114            fr_i(:,:) = 1.0_wp - frld(:,:)        ! adjust ice fraction 
     1115 
     1116            zseaicendg(:,:)=zofrld(:,:) - frld(:,:)         ! find out actual sea ice nudge applied 
     1117 
     1118            ! Nudge sea ice depth to bring it up to a required minimum depth 
     1119 
     1120            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hicif(:,:) < zhicifmin )  
     1121               zhicifinc(:,:) = (zhicifmin - hicif(:,:)) * zincwgt     
     1122            ELSEWHERE 
     1123               zhicifinc(:,:) = 0.0_wp 
     1124            END WHERE 
     1125 
     1126! nudge ice depth 
     1127            hicif(:,:)=hicif(:,:) + zhicifinc(:,:) 
     1128            phicif(:,:)=phicif(:,:) + zhicifinc(:,:)        
     1129 
     1130! seaice salinity balancing (to add) 
     1131 
     1132#endif 
     1133 
     1134#if defined key_cice 
     1135 
     1136! Pass ice increment tendency into CICE 
     1137            ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rdt 
     1138 
     1139#endif 
     1140 
     1141            IF ( kt == nitiaufin_r ) THEN 
     1142               DEALLOCATE( seaice_bkginc ) 
     1143            ENDIF 
     1144 
     1145         ELSE 
     1146 
     1147#if defined key_cice 
     1148 
     1149! Zero ice increment tendency into CICE 
     1150            ndaice_da(:,:) = 0.0_wp 
     1151 
     1152#endif 
     1153 
     1154         ENDIF 
     1155 
     1156      ELSEIF ( ln_asmdin ) THEN 
     1157 
     1158         !-------------------------------------------------------------------- 
     1159         ! Direct Initialization 
     1160         !-------------------------------------------------------------------- 
     1161 
     1162         IF ( kt == nitdin_r ) THEN 
     1163 
     1164            neuler = 0                    ! Force Euler forward step 
     1165 
     1166#if defined key_lim3 || defined key_lim2 
     1167 
     1168            zofrld(:,:)=frld(:,:) 
     1169            zohicif(:,:)=hicif(:,:) 
     1170  
     1171            ! Initialize the now fields the background + increment 
     1172 
     1173            frld(:,:) = MIN( MAX( frld(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 
     1174            pfrld(:,:) = frld(:,:)  
     1175            fr_i(:,:) = 1.0_wp - frld(:,:)        ! adjust ice fraction 
     1176 
     1177            zseaicendg(:,:)=zofrld(:,:) - frld(:,:)         ! find out actual sea ice nudge applied 
     1178 
     1179            ! Nudge sea ice depth to bring it up to a required minimum depth 
     1180 
     1181            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hicif(:,:) < zhicifmin )  
     1182               zhicifinc(:,:) = (zhicifmin - hicif(:,:)) * zincwgt     
     1183            ELSEWHERE 
     1184               zhicifinc(:,:) = 0.0_wp 
     1185            END WHERE 
     1186 
     1187! nudge ice depth 
     1188            hicif(:,:)=hicif(:,:) + zhicifinc(:,:) 
     1189            phicif(:,:)=phicif(:,:)        
     1190 
     1191! seaice salinity balancing (to add) 
     1192   
     1193#endif 
     1194  
     1195#if defined key_cice 
     1196 
     1197! Pass ice increment tendency into CICE - is this correct? 
     1198           ndaice_da(:,:) = seaice_bkginc(:,:) / rdt 
     1199 
     1200#endif 
     1201           IF ( .NOT. PRESENT(kindic) ) THEN 
     1202              DEALLOCATE( seaice_bkginc ) 
     1203           END IF 
     1204 
     1205         ELSE 
     1206 
     1207#if defined key_cice 
     1208 
     1209! Zero ice increment tendency into CICE  
     1210            ndaice_da(:,:) = 0.0_wp 
     1211 
     1212#endif 
     1213          
     1214         ENDIF 
     1215 
     1216!#if defined key_lim3 || defined key_lim2 || defined key_cice 
     1217! 
     1218!            IF (ln_seaicebal ) THEN        
     1219!             !! balancing salinity increments 
     1220!             !! simple case from limflx.F90 (doesn't include a mass flux) 
     1221!             !! assumption is that as ice concentration is reduced or increased 
     1222!             !! the snow and ice depths remain constant 
     1223!             !! note that snow is being created where ice concentration is being increased 
     1224!             !! - could be more sophisticated and 
     1225!             !! not do this (but would need to alter h_snow) 
     1226! 
     1227!             usave(:,:,:)=sb(:,:,:)   ! use array as a temporary store 
     1228! 
     1229!             DO jj = 1, jpj 
     1230!               DO ji = 1, jpi  
     1231!           ! calculate change in ice and snow mass per unit area 
     1232!           ! positive values imply adding salt to the ocean (results from ice formation) 
     1233!           ! fwf : ice formation and melting 
     1234! 
     1235!                 zfons = ( -nfresh_da(ji,jj)*soce + nfsalt_da(ji,jj) )*rdt 
     1236! 
     1237!           ! change salinity down to mixed layer depth 
     1238!                 mld=hmld_kara(ji,jj) 
     1239! 
     1240!           ! prevent small mld 
     1241!           ! less than 10m can cause salinity instability  
     1242!                 IF (mld < 10) mld=10 
     1243! 
     1244!           ! set to bottom of a level  
     1245!                 DO jk = jpk-1, 2, -1 
     1246!                   IF ((mld > gdepw(ji,jj,jk)) .and. (mld < gdepw(ji,jj,jk+1))) THEN  
     1247!                     mld=gdepw(ji,jj,jk+1) 
     1248!                     jkmax=jk 
     1249!                   ENDIF 
     1250!                 ENDDO 
     1251! 
     1252!            ! avoid applying salinity balancing in shallow water or on land 
     1253!            !  
     1254! 
     1255!            ! dsal_ocn (psu kg m^-2) / (kg m^-3 * m) 
     1256! 
     1257!                 dsal_ocn=0.0_wp 
     1258!                 sal_thresh=5.0_wp        ! minimum salinity threshold for salinity balancing 
     1259! 
     1260!                 if (tmask(ji,jj,1) > 0 .AND. tmask(ji,jj,jkmax) > 0 ) & 
     1261!                              dsal_ocn = zfons / (rhop(ji,jj,1) * mld) 
     1262! 
     1263!           ! put increments in for levels in the mixed layer 
     1264!           ! but prevent salinity below a threshold value  
     1265! 
     1266!                   DO jk = 1, jkmax               
     1267! 
     1268!                     IF (dsal_ocn > 0.0_wp .or. sb(ji,jj,jk)+dsal_ocn > sal_thresh) THEN  
     1269!                           sb(ji,jj,jk) = sb(ji,jj,jk) + dsal_ocn 
     1270!                           sn(ji,jj,jk) = sn(ji,jj,jk) + dsal_ocn 
     1271!                     ENDIF 
     1272! 
     1273!                   ENDDO 
     1274! 
     1275!      !            !  salt exchanges at the ice/ocean interface 
     1276!      !            zpmess         = zfons / rdt_ice    ! rdt_ice is ice timestep 
     1277!      ! 
     1278!      !! Adjust fsalt. A +ve fsalt means adding salt to ocean 
     1279!      !!           fsalt(ji,jj) =  fsalt(ji,jj) + zpmess     ! adjust fsalt   
     1280!      !!                
     1281!      !!           emps(ji,jj) = emps(ji,jj) + zpmess        ! or adjust emps (see icestp1d)  
     1282!      !!                                                     ! E-P (kg m-2 s-2) 
     1283!      !            emp(ji,jj) = emp(ji,jj) + zpmess          ! E-P (kg m-2 s-2) 
     1284!               ENDDO !ji 
     1285!             ENDDO !jj! 
     1286! 
     1287!            ENDIF !ln_seaicebal 
     1288! 
     1289!#endif 
     1290 
     1291 
     1292      ENDIF 
     1293 
     1294   END SUBROUTINE seaice_asm_inc 
    9041295   !!====================================================================== 
    9051296END MODULE asminc 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/ASM/asmtrj.F90

    r7363 r7367  
    1414   !!                 ! 2009-06 (F. Vigilant) asm_trj_wri: special case when kt=nit000-1 
    1515   !!                 ! 2009-07 (F. Vigilant) asm_trj_wri: add computation of eiv at restart 
     16    
     17   !!                 ! 2012-11 (A. Weaver) Save avt_bkg for mixing layer computation, remove en_bkg 
    1618   !!---------------------------------------------------------------------- 
    1719 
    … …  
    3537   USE zdfmxl             ! Mixed layer depth 
    3638   USE dom_oce, ONLY :   ndastp 
    37    USE sol_oce, ONLY :   gcx   ! Solver variables defined in memory 
    3839   USE in_out_manager     ! I/O manager 
    3940   USE iom                ! I/O module 
    … …  
    4344   USE ldfeiv             ! eddy induced velocity coef.      (ldf_eiv routine) 
    4445#endif 
    45  
     46#if defined key_lim2 
     47   USE ice_2 
     48#endif 
     49#if defined key_lim3 
     50   USE ice 
     51#endif 
    4652   IMPLICIT NONE 
    4753   PRIVATE 
    … …  
    110116            CALL iom_rstput( kt, nitbkg_r, inum, 'tn'     , tsn(:,:,:,jp_tem) ) 
    111117            CALL iom_rstput( kt, nitbkg_r, inum, 'sn'     , tsn(:,:,:,jp_sal) ) 
     118            CALL iom_rstput( kt, nitbkg_r, inum, 'avt'    , avt               )             
    112119            CALL iom_rstput( kt, nitbkg_r, inum, 'sshn'   , sshn              ) 
    113 #if defined key_zdftke 
    114             CALL iom_rstput( kt, nitbkg_r, inum, 'en'     , en                ) 
    115 #endif 
    116             CALL iom_rstput( kt, nitbkg_r, inum, 'gcx'    , gcx               ) 
    117120            ! 
    118121            CALL iom_close( inum ) 
    … …  
    148151            CALL iom_rstput( kt, nitdin_r, inum, 'tn'     , tsn(:,:,:,jp_tem) ) 
    149152            CALL iom_rstput( kt, nitdin_r, inum, 'sn'     , tsn(:,:,:,jp_sal) ) 
     153            CALL iom_rstput( kt, nitbkg_r, inum, 'avt'    , avt               )             
    150154            CALL iom_rstput( kt, nitdin_r, inum, 'sshn'   , sshn              ) 
     155#if defined key_lim2 || defined key_lim3 
     156            IF(( nn_ice == 2 ) .OR. ( nn_ice == 3 )) THEN 
     157               CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', 1.0 - frld(:,:)   ) 
     158            ENDIF 
     159#endif 
    151160            ! 
    152161            CALL iom_close( inum ) 
    … …  
    222231         CALL iom_rstput( it, it, inum, 'avt'   , avt    ) 
    223232#if defined key_ldfslp 
    224          CALL iom_rstput( it, it, inum, 'uslp'  , uslp   ) 
    225          CALL iom_rstput( it, it, inum, 'vslp'  , vslp   ) 
    226          CALL iom_rstput( it, it, inum, 'wslpi' , wslpi  ) 
    227          CALL iom_rstput( it, it, inum, 'wslpj' , wslpj  ) 
     233         CALL iom_rstput( it, it, inum, 'uslp_hor'  , uslp_hor   ) 
     234         CALL iom_rstput( it, it, inum, 'vslp_hor'  , vslp_hor   ) 
     235         CALL iom_rstput( it, it, inum, 'wslpi_hor' , wslpi_hor  ) 
     236         CALL iom_rstput( it, it, inum, 'wslpj_hor' , wslpj_hor  ) 
     237         CALL iom_rstput( it, it, inum, 'uslp_iso'  , uslp_iso   ) 
     238         CALL iom_rstput( it, it, inum, 'vslp_iso'  , vslp_iso   ) 
     239         CALL iom_rstput( it, it, inum, 'wslpi_iso' , wslpi_iso  ) 
     240         CALL iom_rstput( it, it, inum, 'wslpj_iso' , wslpj_iso  ) 
    228241#endif 
    229242#if defined key_zdfddm 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90

    r7363 r7367  
    5757   LOGICAL                    ::   ln_mask_file             !: =T read bdymask from file 
    5858   LOGICAL                    ::   ln_vol                   !: =T volume correction              
     59   LOGICAL, DIMENSION(jp_bdy) ::   ln_sponge                !: =T use sponge layer  
    5960   ! 
    6061   INTEGER                    ::   nb_bdy                   !: number of open boundary sets 
    … …  
    6263   INTEGER                    ::   nn_volctl                !: = 0 the total volume will have the variability of the surface Flux E-P  
    6364   !                                                        !  = 1 the volume will be constant during all the integration. 
     65   REAL(wp)                   ::   rn_sponge                !: multiplier of diffusion for sponge layer 
     66 
    6467   INTEGER, DIMENSION(jp_bdy) ::   nn_dyn2d                 ! Choice of boundary condition for barotropic variables (U,V,SSH) 
    6568   INTEGER, DIMENSION(jp_bdy) ::   nn_dyn2d_dta           !: = 0 use the initial state as bdy dta ;  
    … …  
    8386   !! Global variables 
    8487   !!---------------------------------------------------------------------- 
    85    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdytmask   !: Mask defining computational domain at T-points 
    86    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdyumask   !: Mask defining computational domain at U-points 
    87    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdyvmask   !: Mask defining computational domain at V-points 
     88   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdytmask      !: Mask defining computational domain at T-points 
     89   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdyumask      !: Mask defining computational domain at U-points 
     90   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bdyvmask      !: Mask defining computational domain at V-points 
     91   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sponge_factor !: Multiplier for diffusion for sponge layer 
    8892 
    8993   REAL(wp)                                    ::   bdysurftot !: Lateral surface of unstructured open boundary 
    … …  
    120124      ! 
    121125      ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj),                    &   
    122          &      STAT=bdy_oce_alloc ) 
     126         &      sponge_factor(jpi,jpj), STAT=bdy_oce_alloc ) 
    123127         ! 
    124128      IF( lk_mpp             )   CALL mpp_sum ( bdy_oce_alloc ) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r7363 r7367  
    3232   USE ice_2 
    3333#endif 
     34   USE sbcapr 
    3435 
    3536   IMPLICIT NONE 
    … …  
    238239               ENDIF 
    239240            ENDIF 
    240             jstart = jend+1 
     241            jstart = jstart + nb_bdy_fld(ib_bdy) 
    241242 
    242243            ! If full velocities in boundary data then split into barotropic and baroclinic data 
    … …  
    281282         END IF ! nn_dta(ib_bdy) = 1 
    282283      END DO  ! ib_bdy 
     284 
     285      IF ( ln_apr_obc ) THEN 
     286         DO ib_bdy = 1, nb_bdy 
     287            IF (nn_tra(ib_bdy).NE.4)THEN 
     288               igrd = 1                      ! meridional velocity 
     289               DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
     290                  ii   = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     291                  ij   = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     292                  dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + ssh_ib(ii,ij) 
     293               ENDDO 
     294            ENDIF 
     295         ENDDO 
     296      ENDIF 
    283297 
    284298      IF( nn_timing == 1 ) CALL timing_stop('bdy_dta') 
    … …  
    317331      TYPE(FLD_N) ::   bn_frld, bn_hicif, bn_hsnif      ! 
    318332#endif 
    319       NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    320 #if defined key_lim2 
    321       NAMELIST/nambdy_dta/ bn_frld, bn_hicif, bn_hsnif 
    322 #endif 
    323       NAMELIST/nambdy_dta/ ln_full_vel 
     333      NAMELIST/nambdy_dta_1/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
     334      NAMELIST/nambdy_dta_2/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
     335#if defined key_lim2 
     336      NAMELIST/nambdy_dta_1/ bn_frld, bn_hicif, bn_hsnif 
     337      NAMELIST/nambdy_dta_2/ bn_frld, bn_hicif, bn_hsnif 
     338#endif 
     339      NAMELIST/nambdy_dta_1/ ln_full_vel 
     340      NAMELIST/nambdy_dta_2/ ln_full_vel 
    324341      !!--------------------------------------------------------------------------- 
    325342 
    … …  
    403420 
    404421            ! Important NOT to rewind here. 
    405             READ( numnam, nambdy_dta ) 
     422            if ( ib_bdy == 1 )  READ( numnam, nambdy_dta_1 ) 
     423            if ( ib_bdy == 2 )  READ( numnam, nambdy_dta_2 ) 
    406424 
    407425            cn_dir_array(ib_bdy) = cn_dir 
    … …  
    554572            ! Recalculate field counts 
    555573            !------------------------- 
    556             nb_bdy_fld_sum = 0 
    557574            IF( ib_bdy .eq. 1 ) THEN  
     575               nb_bdy_fld_sum = 0 
    558576               nb_bdy_fld(ib_bdy) = jfld 
    559577               nb_bdy_fld_sum     = jfld               

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim2.F90

    r7363 r7367  
    5353            CYCLE 
    5454         CASE(jp_frs) 
    55             CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_idx(ib_bdy) ) 
     55            CALL bdy_ice_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy) ) 
    5656         CASE DEFAULT 
    5757            CALL ctl_stop( 'bdy_ice_lim_2 : unrecognised option for open boundaries for ice fields' ) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r7363 r7367  
    8383         &             nn_ice_lim2, nn_ice_lim2_dta,                       & 
    8484#endif 
    85          &             ln_vol, nn_volctl, nn_rimwidth 
     85         &             ln_vol, nn_volctl, ln_sponge, rn_sponge, nn_rimwidth 
    8686      !! 
    8787      NAMELIST/nambdy_index/ nbdysege, jpieob, jpjedt, jpjeft,             & 
    … …  
    127127      ln_vol            = .false. 
    128128      nn_volctl         = -1  ! uninitialised flag 
     129      ln_sponge(:)      = .false.  
     130      rn_sponge         = 0.0  
    129131      nn_rimwidth(:)    = -1  ! uninitialised flag 
    130132 
    … …  
    224226        IF(lwp) WRITE(numout,*) 
    225227 
     228        IF( ln_sponge(ib_bdy) ) THEN                     ! check sponge layer choice  
     229          IF(lwp) WRITE(numout,*) 'Sponge layer applied at open boundaries'  
     230          IF(lwp) WRITE(numout,*) 'Multiplier for diffusion in sponge layer : ', rn_sponge  
     231          IF(lwp) WRITE(numout,*)  
     232        ELSE  
     233          IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries'  
     234          IF(lwp) WRITE(numout,*)  
     235        ENDIF  
     236  
    226237      ENDDO 
    227238 
    228      IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value) 
    229        IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 
    230        IF(lwp) WRITE(numout,*) 
    231        SELECT CASE ( nn_volctl ) 
    232          CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will be constant' 
    233          CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will vary according to the surface E-P flux' 
    234          CASE DEFAULT   ;   CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 
    235        END SELECT 
    236        IF(lwp) WRITE(numout,*) 
    237      ELSE 
    238        IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' 
    239        IF(lwp) WRITE(numout,*) 
    240      ENDIF 
     239      IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value) 
     240        IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 
     241        IF(lwp) WRITE(numout,*) 
     242        SELECT CASE ( nn_volctl ) 
     243          CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will be constant' 
     244          CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will vary according to the surface E-P flux' 
     245          CASE DEFAULT   ;   CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 
     246        END SELECT 
     247        IF(lwp) WRITE(numout,*) 
     248      ELSE 
     249        IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' 
     250        IF(lwp) WRITE(numout,*) 
     251      ENDIF 
     252 
     253      sponge_factor(:,:) = 1.0  
    241254 
    242255      ! ------------------------------------------------- 
    … …  
    247260      ! --------------------------------------------- 
    248261      REWIND( numnam )                     
     262      jpbdta = 1 
    249263      DO ib_bdy = 1, nb_bdy 
    250264 
    251          jpbdta = 1 
    252265         IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! Work out size of global arrays from namelist parameters 
    253266  
    … …  
    317330 
    318331            nblendta(:,ib_bdy) = nblendta(:,ib_bdy) * nn_rimwidth(ib_bdy) 
    319             jpbdta = MAXVAL(nblendta(:,ib_bdy))                
     332            jpbdta = MAX( jpbdta, MAXVAL(nblendta(:,ib_bdy)) ) 
    320333 
    321334 
    … …  
    324337 
    325338            CALL iom_open( cn_coords_file(ib_bdy), inum ) 
    326             jpbdta = 1 
     339 
    327340            DO igrd = 1, jpbgrd 
    328341               id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz )   
    … …  
    330343               jpbdta = MAX(jpbdta, kdimsz(1)) 
    331344            ENDDO 
     345            CALL iom_close( inum ) 
    332346 
    333347         ENDIF  
    … …  
    507521         ELSE            ! Read global index arrays from boundary coordinates file. 
    508522 
     523            CALL iom_open( cn_coords_file(ib_bdy), inum ) 
    509524            DO igrd = 1, jpbgrd 
    510525               CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) 
    … …  
    616631         END DO  
    617632 
    618       ENDDO 
     633         ! Compute multiplier for diffusion for sponge layer  
     634         ! -------------------------------------------------  
     635         IF( ln_sponge(ib_bdy) ) THEN  
     636            igrd=1 
     637            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd)  
     638               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd)  
     639               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd)  
     640               nbr => idx_bdy(ib_bdy)%nbr(ib,igrd)  
     641               sponge_factor(nbi,nbj) = 1.0 + (rn_sponge-1.0) * ( 1.- TANH( FLOAT( nbr - 1 ) *0.5 ) )  
     642            END DO  
     643         ENDIF  
     644 
     645      ENDDO  ! ib_bdy 
    619646 
    620647      ! ------------------------------------------------------ 
    … …  
    773800            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    774801               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    775                nbj => idx_bdy(ib_bdy)%nbi(ib,igrd) 
     802               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    776803               flagu => idx_bdy(ib_bdy)%flagu(ib) 
    777804               bdysurftot = bdysurftot + hu     (nbi  , nbj)                           & 
    … …  
    786813            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    787814               nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    788                nbj => idx_bdy(ib_bdy)%nbi(ib,igrd) 
     815               nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    789816               flagv => idx_bdy(ib_bdy)%flagv(ib) 
    790817               bdysurftot = bdysurftot + hv     (nbi, nbj  )                           & 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DIA/diadct.F90

    r3294 r7367  
    3838  USE dianam          ! build name of file 
    3939  USE lib_mpp         ! distributed memory computing library 
    40 #if defined key_lim2 || defined key_lim3 
    41   USE ice 
     40#if defined key_lim2 
     41  USE ice_2 
     42#endif 
     43#if defined key_lim3 
     44  USE ice_3 
    4245#endif 
    4346  USE domvvl 
    … …  
    4952 
    5053  !! * Routine accessibility 
    51   PUBLIC   dia_dct     ! routine called by step.F90 
    52   PUBLIC   dia_dct_init! routine called by opa.F90 
     54  PUBLIC   dia_dct      ! routine called by step.F90 
     55  PUBLIC   dia_dct_init ! routine called by opa.F90 
     56  PUBLIC   diadct_alloc ! routine called by nemo_init in nemogcm.F90 
    5357  PRIVATE  readsec 
    5458  PRIVATE  removepoints 
    5559  PRIVATE  transport 
    5660  PRIVATE  dia_dct_wri 
     61  PRIVATE  dia_dct_wri_NOOS 
    5762 
    5863#include "domzgr_substitute.h90" 
    … …  
    6570  INTEGER :: nn_dctwri   = 1     ! Frequency of output 
    6671  INTEGER :: nn_secdebug = 0     ! Number of the section to debug 
     72  INTEGER :: nn_dct_h    = 1     ! Frequency of computation for NOOS hourly files 
     73  INTEGER :: nn_dctwri_h = 1     ! Frequency of output for NOOS hourly files 
    6774    
    68   INTEGER, PARAMETER :: nb_class_max  = 10 
    69   INTEGER, PARAMETER :: nb_sec_max    = 150 
    70   INTEGER, PARAMETER :: nb_point_max  = 2000 
    71   INTEGER, PARAMETER :: nb_type_class = 14 
     75  INTEGER, PARAMETER :: nb_class_max  = 11   ! maximum number of classes, i.e. depth levels or density classes 
     76  INTEGER, PARAMETER :: nb_sec_max    = 30   ! maximum number of sections 
     77  INTEGER, PARAMETER :: nb_point_max  = 375  ! maximum number of points in a single section 
     78  INTEGER, PARAMETER :: nb_type       = 14   ! types of calculations, i.e. pos transport, neg transport, heat transport, salt transport 
     79  INTEGER, PARAMETER :: nb_3d_vars    = 5 
     80  INTEGER, PARAMETER :: nb_2d_vars    = 2 
    7281  INTEGER            :: nb_sec  
    7382 
    … …  
    8291  TYPE SECTION 
    8392     CHARACTER(len=60)                            :: name              ! name of the sec 
    84      LOGICAL                                      :: llstrpond         ! true if you want the computation of salt and 
    85                                                                        ! heat transports 
     93     LOGICAL                                      :: llstrpond         ! true if you want the computation of salinity and heat transports 
    8694     LOGICAL                                      :: ll_ice_section    ! ice surface and ice volume computation 
    8795     LOGICAL                                      :: ll_date_line      ! = T if the section crosses the date-line 
    … …  
    95103                                                     ztem            ,&! temperature classes(99 if you don't want) 
    96104                                                     zlay              ! level classes      (99 if you don't want) 
    97      REAL(wp), DIMENSION(nb_type_class,nb_class_max)  :: transport     ! transport output 
     105     REAL(wp), DIMENSION(nb_type,nb_class_max)        :: transport     ! transport output 
     106     REAL(wp), DIMENSION(nb_type,nb_class_max)        :: transport_h   ! transport output 
    98107     REAL(wp)                                         :: slopeSection  ! slope of the section 
    99108     INTEGER                                          :: nb_point      ! number of points in the section 
    … …  
    102111 
    103112  TYPE(SECTION),DIMENSION(nb_sec_max) :: secs ! Array of sections 
    104   
     113 
     114  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::  transports_3d 
     115  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d 
     116  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::  transports_3d_h 
     117  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  transports_2d_h 
     118  REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::  z_hr_output 
    105119  
    106120CONTAINS 
     121 
     122  INTEGER FUNCTION diadct_alloc() 
     123     !!---------------------------------------------------------------------- 
     124     !!                   ***  FUNCTION diadct_alloc  *** 
     125     !!---------------------------------------------------------------------- 
     126     INTEGER :: ierr(2) 
     127     !!---------------------------------------------------------------------- 
     128     ! 
     129     ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk),   STAT=ierr(1) ) 
     130     ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max)    ,   STAT=ierr(2) ) 
     131     ALLOCATE(transports_3d_h(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(3) ) 
     132     ALLOCATE(transports_2d_h(nb_2d_vars,nb_sec_max,nb_point_max)    , STAT=ierr(4) ) 
     133     ALLOCATE(z_hr_output(nb_sec_max,24,nb_class_max)                , STAT=ierr(5) ) 
     134        ! 
     135     diadct_alloc = MAXVAL( ierr ) 
     136     IF( diadct_alloc /= 0 )   CALL ctl_warn('diadct_alloc: failed to allocate arrays') 
     137     ! 
     138  END FUNCTION diadct_alloc 
     139 
    107140 
    108141  SUBROUTINE dia_dct_init 
    … …  
    110143     !!               ***  ROUTINE diadct  ***   
    111144     !! 
    112      !!  ** Purpose: Read the namelist parametres 
     145     !!  ** Purpose: Read the namelist parameters 
    113146     !!              Open output files 
    114147     !! 
    … …  
    121154     REWIND( numnam ) 
    122155     READ  ( numnam, namdct ) 
     156 
     157     IF( ln_NOOS ) THEN 
     158        nn_dct=3600./rdt         ! hard coded for NOOS transects, to give 25 hour means  
     159        nn_dctwri=86400./rdt 
     160        nn_dct_h=1       ! hard coded for NOOS transects, to give hourly data 
     161        nn_dctwri_h=3600./rdt 
     162     ENDIF 
    123163 
    124164     IF( lwp ) THEN 
    … …  
    126166        WRITE(numout,*) "diadct_init: compute transports through sections " 
    127167        WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" 
    128         WRITE(numout,*) "       Frequency of computation: nn_dct    = ",nn_dct 
    129         WRITE(numout,*) "       Frequency of write:       nn_dctwri = ",nn_dctwri 
     168        IF( ln_NOOS ) THEN 
     169           WRITE(numout,*) "       Frequency of computation hard coded to be every hour: nn_dct    = ",nn_dct 
     170           WRITE(numout,*) "       Frequency of write hard coded to average 25 instantaneous hour values: nn_dctwri = ",nn_dctwri 
     171           WRITE(numout,*) "       Frequency of hourly computation hard coded to be every timestep: nn_dct_h  = ",nn_dct_h 
     172           WRITE(numout,*) "       Frequency of hourly write hard coded to every hour: nn_dctwri_h = ",nn_dctwri_h 
     173        ELSE 
     174           WRITE(numout,*) "       Frequency of computation: nn_dct    = ",nn_dct 
     175           WRITE(numout,*) "       Frequency of write:       nn_dctwri = ",nn_dctwri 
     176        ENDIF 
    130177 
    131178        IF      ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN 
    … …  
    146193     !open output file 
    147194     IF( lwp ) THEN 
    148         CALL ctl_opn( numdct_vol,  'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    149         CALL ctl_opn( numdct_heat, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    150         CALL ctl_opn( numdct_salt, 'salt_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     195        IF( ln_NOOS ) THEN 
     196           CALL ctl_opn( numdct_NOOS  ,'NOOS_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     197           CALL ctl_opn( numdct_NOOS_h,'NOOS_transport_h', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     198        ELSE 
     199           CALL ctl_opn( numdct_vol , 'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     200           CALL ctl_opn( numdct_temp, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     201           CALL ctl_opn( numdct_sal , 'salt_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     202        ENDIF 
    151203     ENDIF 
     204 
     205     ! Initialise arrays to zero 
     206     transports_3d(:,:,:,:)  =0._wp 
     207     transports_2d(:,:,:)    =0._wp 
     208     transports_3d_h(:,:,:,:)=0._wp 
     209     transports_2d_h(:,:,:)  =0._wp 
     210     z_hr_output(:,:,:)      =0._wp 
    152211 
    153212     IF( nn_timing == 1 )   CALL timing_stop('dia_dct_init') 
    … …  
    160219     !!               ***  ROUTINE diadct  ***   
    161220     !! 
    162      !!  ** Purpose: Compute sections tranport and write it in numdct file 
     221     !!  Purpose :: Compute section transports and write it in numdct files 
     222     !!   
     223     !!  Method  :: All arrays initialised to zero in dct_init 
     224     !!             Each nn_dct time step call subroutine 'transports' for 
     225     !!               each section to sum the transports. 
     226     !!             Each nn_dctwri time step: 
     227     !!               Divide the arrays by the number of summations to gain 
     228     !!               an average value 
     229     !!               Call dia_dct_sum to sum relevant grid boxes to obtain 
     230     !!               totals for each class (density, depth, temp or sal) 
     231     !!               Call dia_dct_wri to write the transports into file 
     232     !!               Reinitialise all relevant arrays to zero 
    163233     !!--------------------------------------------------------------------- 
    164234     !! * Arguments 
    … …  
    167237     !! * Local variables 
    168238     INTEGER             :: jsec,            &! loop on sections 
    169                             iost,            &! error for opening fileout 
    170                             itotal            ! nb_sec_max*nb_type_class*nb_class_max 
     239                            itotal            ! nb_sec_max*nb_type*nb_class_max 
    171240     LOGICAL             :: lldebug =.FALSE.  ! debug a section   
    172      CHARACTER(len=160)  :: clfileout         ! fileout name 
    173241 
    174242      
    175      INTEGER , DIMENSION(1)             :: ish   ! tmp array for mpp_sum 
    176      INTEGER , DIMENSION(3)             :: ish2  !   " 
    177      REAL(wp), POINTER, DIMENSION(:)    :: zwork !   "  
    178      REAL(wp), POINTER, DIMENSION(:,:,:):: zsum  !   " 
     243     INTEGER , DIMENSION(1)             :: ish      ! tmp array for mpp_sum 
     244     INTEGER , DIMENSION(3)             :: ish2     !   " 
     245     REAL(wp), POINTER, DIMENSION(:)    :: zwork    !   "  
     246     REAL(wp), POINTER, DIMENSION(:,:,:):: zsum     !   " 
    179247 
    180248     !!---------------------------------------------------------------------     
    … …  
    182250 
    183251     IF( lk_mpp )THEN 
    184         itotal = nb_sec_max*nb_type_class*nb_class_max 
    185         CALL wrk_alloc( itotal                                , zwork )  
    186         CALL wrk_alloc( nb_sec_max,nb_type_class,nb_class_max , zsum  ) 
     252        itotal = nb_sec_max*nb_type*nb_class_max 
     253        CALL wrk_alloc( itotal                          , zwork )  
     254        CALL wrk_alloc( nb_sec_max,nb_type,nb_class_max , zsum  ) 
    187255     ENDIF     
    188256  
     257     zwork(:) = 0.0 
     258     zsum(:,:,:) = 0.0 
     259 
    189260     IF( lwp .AND. kt==nit000+nn_dct-1 ) THEN 
    190261         WRITE(numout,*) " " 
    … …  
    194265     ENDIF 
    195266 
    196   
    197      ! Compute transport and write only at nn_dctwri 
    198      IF( MOD(kt,nn_dct)==0 ) THEN  
     267     IF ( MOD(kt,nn_dct)==0 .or. &               ! compute transport every nn_dct time steps 
     268         (ln_NOOS .and. kt==nn_it000 ) )  THEN   ! also include first time step when calculating NOOS 25 hour averages 
    199269 
    200270        DO jsec=1,nb_sec 
    201271 
    202            !debug this section computing ? 
    203272           lldebug=.FALSE. 
    204273           IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND.  kt==nit000+nn_dct-1 .AND. lwp ) lldebug=.TRUE.  
    205274 
    206275           !Compute transport through section   
    207            CALL transport(secs(jsec),lldebug)  
     276           CALL transport(secs(jsec),lldebug,jsec)  
    208277 
    209278        ENDDO 
    … …  
    211280        IF( MOD(kt,nn_dctwri)==0 )THEN 
    212281 
    213            IF( lwp .AND. kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: write at kt = ",kt          
     282           IF( lwp .AND. kt==nit000+nn_dctwri-1 )WRITE(numout,*)"      diadct: average and write at kt = ",kt          
    214283   
     284           !! divide arrays by nn_dctwri/nn_dct to obtain average 
     285           transports_3d(:,:,:,:)=transports_3d(:,:,:,:)/(nn_dctwri/nn_dct) 
     286           transports_2d(:,:,:)  =transports_2d(:,:,:)  /(nn_dctwri/nn_dct) 
     287 
     288           ! Sum over each class 
     289           DO jsec=1,nb_sec 
     290              CALL dia_dct_sum(secs(jsec),jsec) 
     291           ENDDO 
     292  
    215293           !Sum on all procs  
    216294           IF( lk_mpp )THEN 
    217               ish(1)  =  nb_sec_max*nb_type_class*nb_class_max  
    218               ish2    = (/nb_sec_max,nb_type_class,nb_class_max/) 
     295              zsum(:,:,:)=0.0_wp 
     296              ish(1)  =  nb_sec_max*nb_type*nb_class_max  
     297              ish2    = (/nb_sec_max,nb_type,nb_class_max/) 
    219298              DO jsec=1,nb_sec ; zsum(jsec,:,:) = secs(jsec)%transport(:,:) ; ENDDO 
    220299              zwork(:)= RESHAPE(zsum(:,:,:), ish ) 
    … …  
    227306           DO jsec=1,nb_sec 
    228307 
    229               IF( lwp )CALL dia_dct_wri(kt,jsec,secs(jsec)) 
     308              IF( lwp .and. .not. ln_NOOS )CALL dia_dct_wri(kt,jsec,secs(jsec)) 
     309              IF( lwp .and.       ln_NOOS )CALL dia_dct_wri_NOOS(kt,jsec,secs(jsec))   ! use NOOS specific formatting 
    230310             
    231311              !nullify transports values after writing 
     312              transports_3d(:,jsec,:,:)=0.0 
     313              transports_2d(:,jsec,:)=0.0 
    232314              secs(jsec)%transport(:,:)=0.   
     315              IF ( ln_NOOS ) CALL transport(secs(jsec),lldebug,jsec)  ! reinitialise for next 25 hour instantaneous average (overlapping values) 
    233316 
    234317           ENDDO 
    … …  
    238321     ENDIF 
    239322 
     323     IF ( MOD(kt,nn_dct_h)==0 ) THEN            ! compute transport every nn_dct_h time steps 
     324 
     325        DO jsec=1,nb_sec 
     326 
     327           lldebug=.FALSE. 
     328           IF( (jsec==nn_secdebug .OR. nn_secdebug==-1) .AND.  kt==nit000+nn_dct_h-1 .AND. lwp ) lldebug=.TRUE.  
     329 
     330           !Compute transport through section   
     331           CALL transport_h(secs(jsec),lldebug,jsec)  
     332 
     333        ENDDO 
     334              
     335        IF( MOD(kt,nn_dctwri_h)==0 )THEN 
     336 
     337           IF( lwp .AND. kt==nit000+nn_dctwri_h-1 )WRITE(numout,*)"      diadct: average and write hourly files at kt = ",kt          
     338   
     339           !! divide arrays by nn_dctwri/nn_dct to obtain average 
     340           transports_3d_h(:,:,:,:)=transports_3d_h(:,:,:,:)/(nn_dctwri_h/nn_dct_h) 
     341           transports_2d_h(:,:,:)  =transports_2d_h(:,:,:)  /(nn_dctwri_h/nn_dct_h) 
     342 
     343           ! Sum over each class 
     344           DO jsec=1,nb_sec 
     345              CALL dia_dct_sum_h(secs(jsec),jsec) 
     346           ENDDO 
     347  
     348           !Sum on all procs  
     349          IF( lk_mpp )THEN 
     350              ish(1)  =  nb_sec_max*nb_type*nb_class_max  
     351              ish2    = (/nb_sec_max,nb_type,nb_class_max/) 
     352              DO jsec=1,nb_sec ; zsum(jsec,:,:) = secs(jsec)%transport_h(:,:) ; ENDDO 
     353              zwork(:)= RESHAPE(zsum(:,:,:), ish ) 
     354              CALL mpp_sum(zwork, ish(1)) 
     355              zsum(:,:,:)= RESHAPE(zwork,ish2) 
     356              DO jsec=1,nb_sec ; secs(jsec)%transport_h(:,:) = zsum(jsec,:,:) ; ENDDO 
     357           ENDIF 
     358 
     359           !Write the transport 
     360           DO jsec=1,nb_sec 
     361 
     362              IF( lwp .and.       ln_NOOS )CALL dia_dct_wri_NOOS_h(kt/nn_dctwri_h,jsec,secs(jsec))   ! use NOOS specific formatting 
     363             
     364              !nullify transports values after writing 
     365              transports_3d_h(:,jsec,:,:)=0.0 
     366              transports_2d_h(:,jsec,:)=0.0 
     367              secs(jsec)%transport_h(:,:)=0.   
     368              IF ( ln_NOOS ) CALL transport_h(secs(jsec),lldebug,jsec)  ! reinitialise for next 25 hour instantaneous average (overlapping values) 
     369 
     370           ENDDO 
     371 
     372        ENDIF  
     373 
     374     ENDIF     
     375 
    240376     IF( lk_mpp )THEN 
    241         itotal = nb_sec_max*nb_type_class*nb_class_max 
    242         CALL wrk_dealloc( itotal                                , zwork )  
    243         CALL wrk_dealloc( nb_sec_max,nb_type_class,nb_class_max , zsum  ) 
     377        itotal = nb_sec_max*nb_type*nb_class_max 
     378        CALL wrk_dealloc( itotal                          , zwork )  
     379        CALL wrk_dealloc( nb_sec_max,nb_type,nb_class_max , zsum  ) 
    244380     ENDIF     
    245381 
    … …  
    299435        secs(jsec)%zlay         = 99._wp          
    300436        secs(jsec)%transport    =  0._wp   ; secs(jsec)%nb_point       = 0 
     437        secs(jsec)%transport_h  =  0._wp   ; secs(jsec)%nb_point       = 0 
    301438 
    302439        !read section's number / name / computing choices / classes / slopeSection / points number 
    … …  
    331468 
    332469            WRITE(numout,*)       "   Section name :                       ",TRIM(secs(jsec)%name) 
    333             WRITE(numout,*)       "      Compute heat and salt transport ? ",secs(jsec)%llstrpond 
     470            WRITE(numout,*)       "      Compute temperature and salinity transports ? ",secs(jsec)%llstrpond 
    334471            WRITE(numout,*)       "      Compute ice transport ?           ",secs(jsec)%ll_ice_section 
    335472            WRITE(numout,*)       "      Section crosses date-line ?       ",secs(jsec)%ll_date_line 
    … …  
    362499              WRITE(numout,*)"      List of points in global domain:" 
    363500              DO jpt=1,iptglo 
    364                  WRITE(numout,*)'        # I J ',jpt,coordtemp(jpt) 
     501                 WRITE(numout,*)'        # I J ',jpt,coordtemp(jpt),directemp(jpt) 
    365502              ENDDO                   
    366503           ENDIF 
    … …  
    403540 
    404541              IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN 
    405               WRITE(narea+200,*)'avant secs(jsec)%nb_point iptloc ',secs(jsec)%nb_point,iptloc 
    406542              DO jpt = 1,iptloc 
    407543                 iiglo = secs(jsec)%listPoint(jpt)%I + jpizoom - 1 + nimpp - 1 
    408544                 ijglo = secs(jsec)%listPoint(jpt)%J + jpjzoom - 1 + njmpp - 1 
    409                  WRITE(narea+200,*)'avant # I J : ',iiglo,ijglo 
    410545              ENDDO 
    411546              ENDIF 
    … …  
    421556           ENDIF 
    422557           IF(jsec==nn_secdebug .AND. secs(jsec)%nb_point .NE. 0)THEN 
    423               WRITE(narea+200,*)'apres secs(jsec)%nb_point iptloc ',secs(jsec)%nb_point,iptloc 
    424558              DO jpt = 1,secs(jsec)%nb_point 
    425559                 iiglo = secs(jsec)%listPoint(jpt)%I + jpizoom - 1 + nimpp - 1 
    426560                 ijglo = secs(jsec)%listPoint(jpt)%J + jpjzoom - 1 + njmpp - 1 
    427                  WRITE(narea+200,*)'apres # I J : ',iiglo,ijglo 
    428561              ENDDO 
    429562           ENDIF 
    … …  
    534667     CALL wrk_dealloc(    nb_point_max, idirec ) 
    535668     CALL wrk_dealloc( 2, nb_point_max, icoord ) 
     669 
    536670  END SUBROUTINE removepoints 
    537671 
    538   SUBROUTINE transport(sec,ld_debug) 
     672  SUBROUTINE transport(sec,ld_debug,jsec) 
    539673     !!------------------------------------------------------------------------------------------- 
    540674     !!                     ***  ROUTINE transport  *** 
    541675     !! 
    542      !!  ** Purpose : Compute the transport through a section 
    543      !! 
    544      !!  ** Method  :Transport through a given section is equal to the sum of transports 
    545      !!              computed on each proc. 
    546      !!              On each proc,transport is equal to the sum of transport computed through 
    547      !!               segments linking each point of sec%listPoint  with the next one.    
    548      !! 
    549      !!              !BE carefull :           
    550      !!              one section is a sum of segments 
    551      !!              one segment is defined by 2 consectuve points in sec%listPoint 
    552      !!              all points of sec%listPoint are positioned on the F-point of the cell.  
     676     !!  Purpose ::  Compute the transport for each point in a section 
     677     !! 
     678     !!  Method  ::  Loop over each segment, and each vertical level and add the transport 
     679     !!              Be aware :           
     680     !!              One section is a sum of segments 
     681     !!              One segment is defined by 2 consecutive points in sec%listPoint 
     682     !!              All points of sec%listPoint are positioned on the F-point of the cell 
    553683     !!  
    554      !!              There are several loops:                  
    555      !!              loop on the density/temperature/salinity/level classes 
     684     !!              There are two loops:                  
    556685     !!              loop on the segment between 2 nodes 
    557686     !!              loop on the level jk 
    558      !!              test on the density/temperature/salinity/level 
    559      !! 
    560      !! ** Output: sec%transport: volume/mass/ice/heat/salt transport in the 2 directions 
    561      !! 
     687     !! 
     688     !! ** Output: Arrays containing the volume,density,salinity,temperature etc 
     689     !!            transports for each point in a section, summed over each nn_dct. 
    562690     !! 
    563691     !!------------------------------------------------------------------------------------------- 
    … …  
    565693     TYPE(SECTION),INTENT(INOUT) :: sec 
    566694     LOGICAL      ,INTENT(IN)    :: ld_debug 
     695     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section 
    567696     
    568697     !! * Local variables 
    569      INTEGER             :: jk,jseg,jclass,   &!loop on level/segment/classes  
    570                             isgnu  , isgnv     ! 
    571      INTEGER :: ii, ij ! local integer 
    572      REAL(wp):: zumid        , zvmid        ,&!U/V velocity on a cell segment 
    573                 zumid_ice    , zvmid_ice    ,&!U/V ice velocity 
    574                 zTnorm                      ,&!transport of velocity through one cell's sides 
    575                 ztransp1     , ztransp2     ,&!total        transport in directions 1 and 2 
    576                 ztemp1       , ztemp2       ,&!temperature  transport     " 
    577                 zrhoi1       , zrhoi2       ,&!mass         transport     " 
    578                 zrhop1       , zrhop2       ,&!mass         transport     " 
    579                 zsal1        , zsal2        ,&!salinity     transport     " 
    580                 zice_vol_pos , zice_vol_neg ,&!volume  ice  transport     " 
    581                 zice_surf_pos, zice_surf_neg  !surface ice  transport     " 
     698     INTEGER             :: jk,jseg,jclass,    &!loop on level/segment/classes  
     699                            isgnu  , isgnv      ! 
     700     REAL(wp):: zumid        , zvmid        ,  &!U/V velocity on a cell segment 
     701                zumid_ice    , zvmid_ice    ,  &!U/V ice velocity 
     702                zTnorm                          !transport of velocity through one cell's sides 
    582703     REAL(wp):: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep ! temperature/salinity/ssh/potential density /depth at u/v point 
    583704 
    584705     TYPE(POINT_SECTION) :: k 
    585      REAL(wp), POINTER, DIMENSION(:,:):: zsum ! 2D work array 
    586706     !!-------------------------------------------------------- 
    587      CALL wrk_alloc( nb_type_class , nb_class_max , zsum   ) 
    588707 
    589708     IF( ld_debug )WRITE(numout,*)'      Compute transport' 
    590  
    591      !----------------! 
    592      ! INITIALIZATION ! 
    593      !----------------! 
    594      zsum    = 0._wp 
    595      zice_surf_neg = 0._wp ; zice_surf_pos = 0._wp 
    596      zice_vol_pos  = 0._wp ; zice_vol_neg  = 0._wp 
    597709 
    598710     !---------------------------! 
    … …  
    626738        ELSE                                ; isgnv =  1 
    627739        ENDIF 
    628  
    629         IF( ld_debug )write(numout,*)"isgnu isgnv ",isgnu,isgnv 
     740        IF( sec%slopeSection .GE. 9999. )     isgnv =  1 
     741 
     742        IF( ld_debug )write(numout,*)"sec%slopeSection isgnu isgnv ",sec%slopeSection,isgnu,isgnv 
    630743 
    631744        !--------------------------------------! 
    … …  
    670783           END SELECT 
    671784 
    672            !------------------------------- 
    673            !  LOOP ON THE DENSITY CLASSES | 
    674            !------------------------------- 
    675            !The computation is made for each density class 
    676            DO jclass=1,MAX(1,sec%nb_class-1) 
    677  
    678               ztransp1=0._wp ; zrhoi1=0._wp ; zrhop1=0._wp ; ztemp1=0._wp ;zsal1=0._wp 
    679               ztransp2=0._wp ; zrhoi2=0._wp ; zrhop2=0._wp ; ztemp2=0._wp ;zsal2=0._wp 
    680      
    681               !---------------------------| 
    682               !     LOOP ON THE LEVEL     | 
    683               !---------------------------| 
    684               !Sum of the transport on the vertical  
    685               DO jk=1,jpk 
    686                      
    687  
    688                  ! compute temparature, salinity, insitu & potential density, ssh and depth at U/V point 
    689                  SELECT CASE( sec%direction(jseg) ) 
    690                  CASE(0,1) 
    691                     ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
    692                     zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
    693                     zrhop = interp(k%I,k%J,jk,'V',rhop) 
    694                     zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
    695                     zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
    696                  CASE(2,3) 
    697                     ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
    698                     zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
    699                     zrhop = interp(k%I,k%J,jk,'U',rhop) 
    700                     zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
    701                     zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
    702                  END SELECT 
    703  
    704                  zfsdep= gdept(k%I,k%J,jk) 
    705   
    706                  !----------------------------------------------! 
    707                  !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL!  
    708                  !----------------------------------------------! 
    709   
    710                  IF ( (    ((( zrhop .GE. (sec%zsigp(jclass)+1000.  )) .AND.    & 
    711                            (   zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR.    & 
    712                            ( sec%zsigp(jclass) .EQ. 99.)) .AND.                 & 
    713                            ((( zrhoi .GE. (sec%zsigi(jclass) + 1000.  )) .AND.    & 
    714                            (   zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR.    & 
    715                            ( sec%zsigi(jclass) .EQ. 99.)) .AND.                 & 
    716                            ((( zsn .GT. sec%zsal(jclass)) .AND.                & 
    717                            (   zsn .LE. sec%zsal(jclass+1))) .OR.              & 
    718                            ( sec%zsal(jclass) .EQ. 99.)) .AND.                 & 
    719                            ((( ztn .GE. sec%ztem(jclass)) .AND.                & 
    720                            (   ztn .LE. sec%ztem(jclass+1))) .OR.              & 
    721                            ( sec%ztem(jclass) .EQ.99.)) .AND.                  & 
    722                            ((( zfsdep .GE. sec%zlay(jclass)) .AND.            & 
    723                            (   zfsdep .LE. sec%zlay(jclass+1))) .OR.          & 
    724                            ( sec%zlay(jclass) .EQ. 99. ))))   THEN 
    725  
    726  
    727                     !compute velocity with the correct direction 
    728                     SELECT CASE( sec%direction(jseg) ) 
    729                     CASE(0,1)   
    730                        zumid=0. 
    731                        zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk) 
    732                     CASE(2,3) 
    733                        zumid=isgnu*un(k%I,k%J,jk)*umask(k%I,k%J,jk) 
    734                        zvmid=0. 
    735                     END SELECT 
    736  
    737                     !velocity* cell's length * cell's thickness 
    738                     zTnorm=zumid*e2u(k%I,k%J)*  fse3u(k%I,k%J,jk)+     & 
    739                            zvmid*e1v(k%I,k%J)*  fse3v(k%I,k%J,jk) 
     785           !---------------------------| 
     786           !     LOOP ON THE LEVEL     | 
     787           !---------------------------| 
     788           !Sum of the transport on the vertical  
     789           DO jk=1,mbathy(k%I,k%J) 
     790 
     791              ! compute temparature, salinity, insitu & potential density, ssh and depth at U/V point 
     792              SELECT CASE( sec%direction(jseg) ) 
     793              CASE(0,1) 
     794                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
     795                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
     796                 zrhop = interp(k%I,k%J,jk,'V',rhop) 
     797                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
     798                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
     799              CASE(2,3) 
     800                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
     801                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
     802                 zrhop = interp(k%I,k%J,jk,'U',rhop) 
     803                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
     804                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
     805              END SELECT 
     806 
     807              zfsdep= gdept(k%I,k%J,jk) 
     808  
     809              !compute velocity with the correct direction 
     810              SELECT CASE( sec%direction(jseg) ) 
     811              CASE(0,1)   
     812                 zumid=0. 
     813                 zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk) 
     814              CASE(2,3) 
     815                 zumid=isgnu*un(k%I,k%J,jk)*umask(k%I,k%J,jk) 
     816                 zvmid=0. 
     817              END SELECT 
     818 
     819              !zTnorm=transport through one cell; 
     820              !velocity* cell's length * cell's thickness 
     821              zTnorm=zumid*e2u(k%I,k%J)*  fse3u(k%I,k%J,jk)+     & 
     822                     zvmid*e1v(k%I,k%J)*  fse3v(k%I,k%J,jk) 
    740823 
    741824#if ! defined key_vvl 
    742                     !add transport due to free surface 
    743                     IF( jk==1 )THEN 
    744                        zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) + & 
    745                                          zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) 
    746                     ENDIF 
     825              !add transport due to free surface 
     826              IF( jk==1 )THEN 
     827                 zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) + & 
     828                                   zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) 
     829              ENDIF 
    747830#endif 
    748                     !COMPUTE TRANSPORT  
    749                     !zTnorm=transport through one cell for one class 
    750                     !ztransp1 or ztransp2=transport through one cell i 
    751                     !                     for one class for one direction 
    752                     IF( zTnorm .GE. 0 )THEN 
    753  
    754                        ztransp1=zTnorm+ztransp1 
    755   
    756                        IF ( sec%llstrpond ) THEN 
    757                           ztemp1 = ztemp1  + zTnorm * ztn  
    758                           zsal1  = zsal1   + zTnorm * zsn 
    759                           zrhoi1 = zrhoi1  + zTnorm * zrhoi 
    760                           zrhop1 = zrhop1  + zTnorm * zrhop 
    761                        ENDIF 
    762  
    763                     ELSE 
    764  
    765                        ztransp2=(zTnorm)+ztransp2 
    766  
    767                        IF ( sec%llstrpond ) THEN 
    768                           ztemp2 = ztemp2  + zTnorm * ztn  
    769                           zsal2  = zsal2   + zTnorm * zsn 
    770                           zrhoi2 = zrhoi2  + zTnorm * zrhoi 
    771                           zrhop2 = zrhop2  + zTnorm * zrhop 
    772                        ENDIF 
    773                     ENDIF 
    774   
    775              
    776                  ENDIF ! end of density test 
    777               ENDDO!end of loop on the level 
    778  
    779               !ZSUM=TRANSPORT FOR EACH CLASSES FOR THE  DIRECTIONS 
    780               !--------------------------------------------------- 
    781               zsum(1,jclass)     = zsum(1,jclass)+ztransp1 
    782               zsum(2,jclass)     = zsum(2,jclass)+ztransp2 
    783               IF( sec%llstrpond )THEN 
    784                  zsum(3 ,jclass) = zsum( 3,jclass)+zrhoi1 
    785                  zsum(4 ,jclass) = zsum( 4,jclass)+zrhoi2 
    786                  zsum(5 ,jclass) = zsum( 5,jclass)+zrhop1 
    787                  zsum(6 ,jclass) = zsum( 6,jclass)+zrhop2 
    788                  zsum(7 ,jclass) = zsum( 7,jclass)+ztemp1 
    789                  zsum(8 ,jclass) = zsum( 8,jclass)+ztemp2 
    790                  zsum(9 ,jclass) = zsum( 9,jclass)+zsal1 
    791                  zsum(10,jclass) = zsum(10,jclass)+zsal2 
     831              !COMPUTE TRANSPORT  
     832 
     833              transports_3d(1,jsec,jseg,jk) = transports_3d(1,jsec,jseg,jk) + zTnorm 
     834  
     835              IF ( sec%llstrpond ) THEN 
     836                 transports_3d(2,jsec,jseg,jk) = transports_3d(2,jsec,jseg,jk)  + zTnorm * zrhoi 
     837                 transports_3d(3,jsec,jseg,jk) = transports_3d(3,jsec,jseg,jk)  + zTnorm * zrhop 
     838                 transports_3d(4,jsec,jseg,jk) = transports_3d(4,jsec,jseg,jk)  + zTnorm * 4.e+3_wp * (ztn+273.15) * 1026._wp 
     839                 transports_3d(5,jsec,jseg,jk) = transports_3d(5,jsec,jseg,jk)  + zTnorm * 0.001 * zsn * 1026._wp 
    792840              ENDIF 
    793     
    794            ENDDO !end of loop on the density classes 
     841 
     842           ENDDO !end of loop on the level 
    795843 
    796844#if defined key_lim2 || defined key_lim3 
    … …  
    816864              zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) 
    817865    
    818               IF( zTnorm .GE. 0)THEN 
    819                  zice_vol_pos = (zTnorm)*   & 
    820                                       (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    821                                      *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  & 
    822                                        hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) & 
    823                                       +zice_vol_pos 
    824                  zice_surf_pos = (zTnorm)*   & 
    825                                        (1.0 -  frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    826                                       +zice_surf_pos 
    827               ELSE 
    828                  zice_vol_neg=(zTnorm)*   & 
     866              transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)*   & 
    829867                                   (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    830868                                  *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  & 
    831869                                    hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) & 
    832                                   +zice_vol_neg 
    833                  zice_surf_neg=(zTnorm)*   & 
    834                                     (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
    835                                      +zice_surf_neg 
    836               ENDIF 
    837     
    838               zsum(11,1) = zsum(11,1)+zice_vol_pos 
    839               zsum(12,1) = zsum(12,1)+zice_vol_neg 
    840               zsum(13,1) = zsum(13,1)+zice_surf_pos 
    841               zsum(14,1) = zsum(14,1)+zice_surf_neg 
     870                                   +zice_vol_pos 
     871              transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)*   & 
     872                                    (1.0 -  frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
     873                                   +zice_surf_pos 
    842874    
    843875           ENDIF !end of ice case 
    … …  
    846878        ENDDO !end of loop on the segment 
    847879 
    848  
    849      ELSE  !if sec%nb_point =0 
    850         zsum(1:2,:)=0. 
    851         IF (sec%llstrpond) zsum(3:10,:)=0. 
    852         zsum( 11:14,:)=0. 
    853880     ENDIF   !end of sec%nb_point =0 case 
    854  
    855      !-------------------------------| 
    856      !FINISH COMPUTING TRANSPORTS    | 
    857      !-------------------------------| 
    858      DO jclass=1,MAX(1,sec%nb_class-1) 
    859         sec%transport(1,jclass)=sec%transport(1,jclass)+zsum(1,jclass)*1.E-6 
    860         sec%transport(2,jclass)=sec%transport(2,jclass)+zsum(2,jclass)*1.E-6 
    861         IF( sec%llstrpond ) THEN 
    862            IF( zsum(1,jclass) .NE. 0._wp ) THEN 
    863               sec%transport( 3,jclass) = sec%transport( 3,jclass) + zsum( 3,jclass)/zsum(1,jclass) 
    864               sec%transport( 5,jclass) = sec%transport( 5,jclass) + zsum( 5,jclass)/zsum(1,jclass) 
    865               sec%transport( 7,jclass) = sec%transport( 7,jclass) + zsum( 7,jclass) 
    866               sec%transport( 9,jclass) = sec%transport( 9,jclass) + zsum( 9,jclass) 
    867            ENDIF 
    868            IF( zsum(2,jclass) .NE. 0._wp )THEN 
    869               sec%transport( 4,jclass) = sec%transport( 4,jclass) + zsum( 4,jclass)/zsum(2,jclass) 
    870               sec%transport( 6,jclass) = sec%transport( 6,jclass) + zsum( 6,jclass)/zsum(2,jclass) 
    871               sec%transport( 8,jclass) = sec%transport( 8,jclass) + zsum( 8,jclass) 
    872               sec%transport(10,jclass) = sec%transport(10,jclass) + zsum(10,jclass) 
    873            ENDIF 
    874         ELSE 
    875            sec%transport( 3,jclass) = 0._wp 
    876            sec%transport( 4,jclass) = 0._wp 
    877            sec%transport( 5,jclass) = 0._wp 
    878            sec%transport( 6,jclass) = 0._wp 
    879            sec%transport( 7,jclass) = 0._wp 
    880            sec%transport( 8,jclass) = 0._wp 
    881            sec%transport(10,jclass) = 0._wp 
    882         ENDIF 
    883      ENDDO    
    884  
    885      IF( sec%ll_ice_section ) THEN 
    886         sec%transport( 9,1)=sec%transport( 9,1)+zsum( 9,1)*1.E-6 
    887         sec%transport(10,1)=sec%transport(10,1)+zsum(10,1)*1.E-6 
    888         sec%transport(11,1)=sec%transport(11,1)+zsum(11,1)*1.E-6 
    889         sec%transport(12,1)=sec%transport(12,1)+zsum(12,1)*1.E-6 
    890      ENDIF 
    891  
    892      CALL wrk_dealloc( nb_type_class , nb_class_max , zsum   ) 
    893881     ! 
    894882  END SUBROUTINE transport 
    895    
     883 
     884  SUBROUTINE transport_h(sec,ld_debug,jsec) 
     885     !!------------------------------------------------------------------------------------------- 
     886     !!                     ***  ROUTINE hourly_transport  *** 
     887     !! 
     888     !!              Exactly as routine transport but for data summed at 
     889     !!              each time step and averaged each hour 
     890     !! 
     891     !!  Purpose ::  Compute the transport for each point in a section 
     892     !! 
     893     !!  Method  ::  Loop over each segment, and each vertical level and add the transport 
     894     !!              Be aware :           
     895     !!              One section is a sum of segments 
     896     !!              One segment is defined by 2 consecutive points in sec%listPoint 
     897     !!              All points of sec%listPoint are positioned on the F-point of the cell 
     898     !!  
     899     !!              There are two loops:                  
     900     !!              loop on the segment between 2 nodes 
     901     !!              loop on the level jk 
     902     !! 
     903     !! ** Output: Arrays containing the volume,density,salinity,temperature etc 
     904     !!            transports for each point in a section, summed over each nn_dct. 
     905     !! 
     906     !!------------------------------------------------------------------------------------------- 
     907     !! * Arguments 
     908     TYPE(SECTION),INTENT(INOUT) :: sec 
     909     LOGICAL      ,INTENT(IN)    :: ld_debug 
     910     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section 
     911     
     912     !! * Local variables 
     913     INTEGER             :: jk,jseg,jclass,    &!loop on level/segment/classes  
     914                            isgnu  , isgnv      ! 
     915     REAL(wp):: zumid        , zvmid        ,  &!U/V velocity on a cell segment 
     916                zumid_ice    , zvmid_ice    ,  &!U/V ice velocity 
     917                zTnorm                          !transport of velocity through one cell's sides 
     918     REAL(wp):: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep ! temperature/salinity/ssh/potential density /depth at u/v point 
     919 
     920     TYPE(POINT_SECTION) :: k 
     921     !!-------------------------------------------------------- 
     922 
     923     IF( ld_debug )WRITE(numout,*)'      Compute transport' 
     924 
     925     !---------------------------! 
     926     !  COMPUTE TRANSPORT        ! 
     927     !---------------------------! 
     928     IF(sec%nb_point .NE. 0)THEN    
     929 
     930        !---------------------------------------------------------------------------------------------------- 
     931        !Compute sign for velocities: 
     932        ! 
     933        !convention: 
     934        !   non horizontal section: direction + is toward left hand of section 
     935        !       horizontal section: direction + is toward north of section 
     936        ! 
     937        ! 
     938        !       slopeSection < 0     slopeSection > 0       slopeSection=inf            slopeSection=0 
     939        !       ----------------      -----------------     ---------------             -------------- 
     940        ! 
     941        !   isgnv=1         direction +       
     942        !  ______         _____             ______                                                    
     943        !        |           //|            |                  |                         direction +    
     944        !        | isgnu=1  // |            |isgnu=1           |isgnu=1                     /|\ 
     945        !        |_______  //         ______|    \\            | ---\                        | 
     946        !               |             | isgnv=-1  \\ |         | ---/ direction +       ____________ 
     947        !               |             |          __\\|         |                     
     948        !               |             |     direction +        |                      isgnv=1                                  
     949        !                                                       
     950        !---------------------------------------------------------------------------------------------------- 
     951        isgnu = 1 
     952        IF( sec%slopeSection .GT. 0 ) THEN  ; isgnv = -1  
     953        ELSE                                ; isgnv =  1 
     954        ENDIF 
     955 
     956        IF( ld_debug )write(numout,*)"isgnu isgnv ",isgnu,isgnv 
     957 
     958        !--------------------------------------! 
     959        ! LOOP ON THE SEGMENT BETWEEN 2 NODES  ! 
     960        !--------------------------------------! 
     961        DO jseg=1,MAX(sec%nb_point-1,0) 
     962               
     963           !------------------------------------------------------------------------------------------- 
     964           ! Select the appropriate coordinate for computing the velocity of the segment 
     965           ! 
     966           !                      CASE(0)                                    Case (2) 
     967           !                      -------                                    -------- 
     968           !  listPoint(jseg)                 listPoint(jseg+1)       listPoint(jseg)  F(i,j)       
     969           !      F(i,j)----------V(i+1,j)-------F(i+1,j)                               | 
     970           !                                                                            | 
     971           !                                                                            | 
     972           !                                                                            | 
     973           !                      Case (3)                                            U(i,j) 
     974           !                      --------                                              | 
     975           !                                                                            | 
     976           !  listPoint(jseg+1) F(i,j+1)                                                | 
     977           !                        |                                                   | 
     978           !                        |                                                   | 
     979           !                        |                                 listPoint(jseg+1) F(i,j-1) 
     980           !                        |                                             
     981           !                        |                                             
     982           !                     U(i,j+1)                                             
     983           !                        |                                       Case(1)      
     984           !                        |                                       ------       
     985           !                        |                                             
     986           !                        |                 listPoint(jseg+1)             listPoint(jseg)                            
     987           !                        |                 F(i-1,j)-----------V(i,j) -------f(jseg)                            
     988           ! listPoint(jseg)     F(i,j) 
     989           !  
     990           !------------------------------------------------------------------------------------------- 
     991 
     992           SELECT CASE( sec%direction(jseg) ) 
     993           CASE(0)  ;   k = sec%listPoint(jseg) 
     994           CASE(1)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) 
     995           CASE(2)  ;   k = sec%listPoint(jseg) 
     996           CASE(3)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) 
     997           END SELECT 
     998 
     999           !---------------------------| 
     1000           !     LOOP ON THE LEVEL     | 
     1001           !---------------------------| 
     1002           !Sum of the transport on the vertical  
     1003           DO jk=1,mbathy(k%I,k%J) 
     1004 
     1005              ! compute temparature, salinity, insitu & potential density, ssh and depth at U/V point 
     1006              SELECT CASE( sec%direction(jseg) ) 
     1007              CASE(0,1) 
     1008                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
     1009                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
     1010                 zrhop = interp(k%I,k%J,jk,'V',rhop) 
     1011                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
     1012                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
     1013              CASE(2,3) 
     1014                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
     1015                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
     1016                 zrhop = interp(k%I,k%J,jk,'U',rhop) 
     1017                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
     1018                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
     1019              END SELECT 
     1020 
     1021              zfsdep= gdept(k%I,k%J,jk) 
     1022  
     1023              !compute velocity with the correct direction 
     1024              SELECT CASE( sec%direction(jseg) ) 
     1025              CASE(0,1)   
     1026                 zumid=0. 
     1027                 zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk) 
     1028              CASE(2,3) 
     1029                 zumid=isgnu*un(k%I,k%J,jk)*umask(k%I,k%J,jk) 
     1030                 zvmid=0. 
     1031              END SELECT 
     1032 
     1033              !zTnorm=transport through one cell; 
     1034              !velocity* cell's length * cell's thickness 
     1035              zTnorm=zumid*e2u(k%I,k%J)*  fse3u(k%I,k%J,jk)+     & 
     1036                     zvmid*e1v(k%I,k%J)*  fse3v(k%I,k%J,jk) 
     1037 
     1038#if ! defined key_vvl 
     1039              !add transport due to free surface 
     1040              IF( jk==1 )THEN 
     1041                 zTnorm = zTnorm + zumid* e2u(k%I,k%J) * zsshn * umask(k%I,k%J,jk) + & 
     1042                                   zvmid* e1v(k%I,k%J) * zsshn * vmask(k%I,k%J,jk) 
     1043              ENDIF 
     1044#endif 
     1045              !COMPUTE TRANSPORT  
     1046 
     1047              transports_3d_h(1,jsec,jseg,jk) = transports_3d_h(1,jsec,jseg,jk) + zTnorm 
     1048  
     1049              IF ( sec%llstrpond ) THEN 
     1050                 transports_3d_h(2,jsec,jseg,jk) = transports_3d_h(2,jsec,jseg,jk)  + zTnorm * zrhoi 
     1051                 transports_3d_h(3,jsec,jseg,jk) = transports_3d_h(3,jsec,jseg,jk)  + zTnorm * zrhop 
     1052                 transports_3d_h(4,jsec,jseg,jk) = transports_3d_h(4,jsec,jseg,jk)  + zTnorm * 4.e+3_wp * (ztn+273.15) * 1026._wp 
     1053                 transports_3d_h(5,jsec,jseg,jk) = transports_3d_h(5,jsec,jseg,jk)  + zTnorm * 0.001 * zsn * 1026._wp 
     1054              ENDIF 
     1055 
     1056           ENDDO !end of loop on the level 
     1057 
     1058#if defined key_lim2 || defined key_lim3 
     1059 
     1060           !ICE CASE     
     1061           !------------ 
     1062           IF( sec%ll_ice_section )THEN 
     1063              SELECT CASE (sec%direction(jseg)) 
     1064              CASE(0) 
     1065                 zumid_ice = 0 
     1066                 zvmid_ice =  isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1)) 
     1067              CASE(1) 
     1068                 zumid_ice = 0 
     1069                 zvmid_ice =  isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1)) 
     1070              CASE(2) 
     1071                 zvmid_ice = 0 
     1072                 zumid_ice =  isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1)) 
     1073              CASE(3) 
     1074                 zvmid_ice = 0 
     1075                 zumid_ice =  isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1)) 
     1076              END SELECT 
     1077    
     1078              zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) 
     1079    
     1080              transports_2d_h(1,jsec,jseg) = transports_2d_h(1,jsec,jseg) + (zTnorm)*   & 
     1081                                   (1.0 - frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
     1082                                  *(hsnif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J) +  & 
     1083                                    hicif(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J)) & 
     1084                                   +zice_vol_pos 
     1085              transports_2d_h(2,jsec,jseg) = transports_2d_h(2,jsec,jseg) + (zTnorm)*   & 
     1086                                    (1.0 -  frld(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J))  & 
     1087                                   +zice_surf_pos 
     1088    
     1089           ENDIF !end of ice case 
     1090#endif 
     1091  
     1092        ENDDO !end of loop on the segment 
     1093 
     1094     ENDIF   !end of sec%nb_point =0 case 
     1095     ! 
     1096  END SUBROUTINE transport_h 
     1097  
     1098  SUBROUTINE dia_dct_sum(sec,jsec) 
     1099     !!------------------------------------------------------------- 
     1100     !! Purpose: Average the transport over nn_dctwri time steps  
     1101     !! and sum over the density/salinity/temperature/depth classes 
     1102     !! 
     1103     !! Method:  
     1104     !!           Sum over relevant grid cells to obtain values 
     1105     !!           for each 
     1106     !!              There are several loops:                  
     1107     !!              loop on the segment between 2 nodes 
     1108     !!              loop on the level jk 
     1109     !!              loop on the density/temperature/salinity/level classes 
     1110     !!              test on the density/temperature/salinity/level 
     1111     !! 
     1112     !!  ** Method  :Transport through a given section is equal to the sum of transports 
     1113     !!              computed on each proc. 
     1114     !!              On each proc,transport is equal to the sum of transport computed through 
     1115     !!               segments linking each point of sec%listPoint  with the next one.    
     1116     !! 
     1117     !!------------------------------------------------------------- 
     1118     !! * arguments 
     1119     TYPE(SECTION),INTENT(INOUT) :: sec 
     1120     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section 
     1121 
     1122     TYPE(POINT_SECTION) :: k 
     1123     INTEGER  :: jk,jseg,jclass                        !loop on level/segment/classes  
     1124     REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep ! temperature/salinity/ssh/potential density /depth at u/v point 
     1125     !!------------------------------------------------------------- 
     1126 
     1127     !! Sum the relevant segments to obtain values for each class 
     1128     IF(sec%nb_point .NE. 0)THEN    
     1129 
     1130        !--------------------------------------! 
     1131        ! LOOP ON THE SEGMENT BETWEEN 2 NODES  ! 
     1132        !--------------------------------------! 
     1133        DO jseg=1,MAX(sec%nb_point-1,0) 
     1134            
     1135           !------------------------------------------------------------------------------------------- 
     1136           ! Select the appropriate coordinate for computing the velocity of the segment 
     1137           ! 
     1138           !                      CASE(0)                                    Case (2) 
     1139           !                      -------                                    -------- 
     1140           !  listPoint(jseg)                 listPoint(jseg+1)       listPoint(jseg)  F(i,j)       
     1141           !      F(i,j)----------V(i+1,j)-------F(i+1,j)                               | 
     1142           !                                                                            | 
     1143           !                                                                            | 
     1144           !                                                                            | 
     1145           !                      Case (3)                                            U(i,j) 
     1146           !                      --------                                              | 
     1147           !                                                                            | 
     1148           !  listPoint(jseg+1) F(i,j+1)                                                | 
     1149           !                        |                                                   | 
     1150           !                        |                                                   | 
     1151           !                        |                                 listPoint(jseg+1) F(i,j-1) 
     1152           !                        |                                             
     1153           !                        |                                             
     1154           !                     U(i,j+1)                                             
     1155           !                        |                                       Case(1)      
     1156           !                        |                                       ------       
     1157           !                        |                                             
     1158           !                        |                 listPoint(jseg+1)             listPoint(jseg)                            
     1159           !                        |                 F(i-1,j)-----------V(i,j) -------f(jseg)                            
     1160           ! listPoint(jseg)     F(i,j) 
     1161           !  
     1162           !------------------------------------------------------------------------------------------- 
     1163 
     1164           SELECT CASE( sec%direction(jseg) ) 
     1165           CASE(0)  ;   k = sec%listPoint(jseg) 
     1166           CASE(1)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) 
     1167           CASE(2)  ;   k = sec%listPoint(jseg) 
     1168           CASE(3)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) 
     1169           END SELECT 
     1170 
     1171           !---------------------------| 
     1172           !     LOOP ON THE LEVEL     | 
     1173           !---------------------------| 
     1174           !Sum of the transport on the vertical  
     1175           DO jk=1,mbathy(k%I,k%J) 
     1176 
     1177              ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point 
     1178              SELECT CASE( sec%direction(jseg) ) 
     1179              CASE(0,1) 
     1180                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
     1181                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
     1182                 zrhop = interp(k%I,k%J,jk,'V',rhop) 
     1183                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
     1184                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
     1185              CASE(2,3) 
     1186                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
     1187                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
     1188                 zrhop = interp(k%I,k%J,jk,'U',rhop) 
     1189                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
     1190                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
     1191              END SELECT 
     1192 
     1193              zfsdep= gdept(k%I,k%J,jk) 
     1194  
     1195              !------------------------------- 
     1196              !  LOOP ON THE DENSITY CLASSES | 
     1197              !------------------------------- 
     1198              !The computation is made for each density/heat/salt/... class 
     1199              DO jclass=1,MAX(1,sec%nb_class-1) 
     1200 
     1201                 !----------------------------------------------! 
     1202                 !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL!  
     1203                 !----------------------------------------------! 
     1204  
     1205                 IF ( (                                                    & 
     1206                    ((( zrhop .GE. (sec%zsigp(jclass)+1000.  )) .AND.      & 
     1207                    (   zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR.     & 
     1208                    ( sec%zsigp(jclass) .EQ. 99.)) .AND.                   & 
     1209 
     1210                    ((( zrhoi .GE. (sec%zsigi(jclass) + 1000.  )) .AND.    & 
     1211                    (   zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR.     & 
     1212                    ( sec%zsigi(jclass) .EQ. 99.)) .AND.                   & 
     1213 
     1214                    ((( zsn .GT. sec%zsal(jclass)) .AND.                   & 
     1215                    (   zsn .LE. sec%zsal(jclass+1))) .OR.                 & 
     1216                    ( sec%zsal(jclass) .EQ. 99.)) .AND.                    & 
     1217 
     1218                    ((( ztn .GE. sec%ztem(jclass)) .AND.                   & 
     1219                    (   ztn .LE. sec%ztem(jclass+1))) .OR.                 & 
     1220                    ( sec%ztem(jclass) .EQ.99.)) .AND.                     & 
     1221 
     1222                    ((( zfsdep .GE. sec%zlay(jclass)) .AND.                & 
     1223                    (   zfsdep .LE. sec%zlay(jclass+1))) .OR.              & 
     1224                    ( sec%zlay(jclass) .EQ. 99. ))                         & 
     1225                                                                   ))   THEN 
     1226 
     1227                    !SUM THE TRANSPORTS FOR EACH CLASSES FOR THE POSITIVE AND NEGATIVE DIRECTIONS 
     1228                    !---------------------------------------------------------------------------- 
     1229                    IF (transports_3d(1,jsec,jseg,jk) .GE. 0.0) THEN  
     1230                       sec%transport(1,jclass) = sec%transport(1,jclass)+transports_3d(1,jsec,jseg,jk) 
     1231                    ELSE 
     1232                       sec%transport(2,jclass) = sec%transport(2,jclass)+transports_3d(1,jsec,jseg,jk) 
     1233                    ENDIF 
     1234                    IF( sec%llstrpond )THEN 
     1235 
     1236                       IF( transports_3d(1,jsec,jseg,jk) .NE. 0._wp ) THEN 
     1237 
     1238                          IF (transports_3d(2,jsec,jseg,jk)/transports_3d(1,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1239                             sec%transport(3,jclass) = sec%transport(3,jclass)+transports_3d(2,jsec,jseg,jk)/transports_3d(1,jsec,jseg,jk) 
     1240                          ELSE 
     1241                             sec%transport(4,jclass) = sec%transport(4,jclass)+transports_3d(2,jsec,jseg,jk)/transports_3d(1,jsec,jseg,jk) 
     1242                          ENDIF 
     1243 
     1244                          IF ( transports_3d(3,jsec,jseg,jk)/transports_3d(1,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1245                             sec%transport(5,jclass) = sec%transport(5,jclass)+transports_3d(3,jsec,jseg,jk)/transports_3d(1,jsec,jseg,jk) 
     1246                          ELSE 
     1247                             sec%transport(6,jclass) = sec%transport(6,jclass)+transports_3d(3,jsec,jseg,jk)/transports_3d(1,jsec,jseg,jk) 
     1248                          ENDIF 
     1249 
     1250                       ENDIF 
     1251 
     1252                       IF ( transports_3d(4,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1253                          sec%transport(7,jclass) = sec%transport(7,jclass)+transports_3d(4,jsec,jseg,jk) 
     1254                       ELSE 
     1255                          sec%transport(8,jclass) = sec%transport(8,jclass)+transports_3d(4,jsec,jseg,jk) 
     1256                       ENDIF 
     1257 
     1258                       IF ( transports_3d(5,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1259                          sec%transport( 9,jclass) = sec%transport( 9,jclass)+transports_3d(5,jsec,jseg,jk) 
     1260                       ELSE 
     1261                          sec%transport(10,jclass) = sec%transport(10,jclass)+transports_3d(5,jsec,jseg,jk) 
     1262                       ENDIF 
     1263 
     1264                    ELSE 
     1265                       sec%transport( 3,jclass) = 0._wp 
     1266                       sec%transport( 4,jclass) = 0._wp 
     1267                       sec%transport( 5,jclass) = 0._wp 
     1268                       sec%transport( 6,jclass) = 0._wp 
     1269                       sec%transport( 7,jclass) = 0._wp 
     1270                       sec%transport( 8,jclass) = 0._wp 
     1271                       sec%transport( 9,jclass) = 0._wp 
     1272                       sec%transport(10,jclass) = 0._wp 
     1273                    ENDIF 
     1274 
     1275                 ENDIF ! end of test if point is in class 
     1276    
     1277              ENDDO ! end of loop on the classes 
     1278 
     1279           ENDDO ! loop over jk 
     1280 
     1281#if defined key_lim2 || defined key_lim3 
     1282 
     1283           !ICE CASE     
     1284           IF( sec%ll_ice_section )THEN 
     1285 
     1286              IF ( transports_2d(1,jsec,jseg) .GE. 0.0 ) THEN 
     1287                 sec%transport(11,1) = sec%transport(11,1)+transports_2d(1,jsec,jseg) 
     1288              ELSE 
     1289                 sec%transport(12,1) = sec%transport(12,1)+transports_2d(1,jsec,jseg) 
     1290              ENDIF 
     1291 
     1292              IF ( transports_2d(3,jsec,jseg) .GE. 0.0 ) THEN 
     1293                 sec%transport(13,1) = sec%transport(13,1)+transports_2d(2,jsec,jseg) 
     1294              ELSE 
     1295                 sec%transport(14,1) = sec%transport(14,1)+transports_2d(2,jsec,jseg) 
     1296              ENDIF 
     1297 
     1298           ENDIF !end of ice case 
     1299#endif 
     1300  
     1301        ENDDO !end of loop on the segment 
     1302 
     1303     ELSE  !if sec%nb_point =0 
     1304        sec%transport(1:2,:)=0. 
     1305        IF (sec%llstrpond) sec%transport(3:10,:)=0. 
     1306        IF (sec%ll_ice_section) sec%transport( 11:14,:)=0. 
     1307     ENDIF !end of sec%nb_point =0 case 
     1308 
     1309  END SUBROUTINE dia_dct_sum 
     1310  
     1311  SUBROUTINE dia_dct_sum_h(sec,jsec) 
     1312     !!------------------------------------------------------------- 
     1313     !! Exactly as dia_dct_sum but for hourly files containing data summed at each time step 
     1314     !! 
     1315     !! Purpose: Average the transport over nn_dctwri time steps  
     1316     !! and sum over the density/salinity/temperature/depth classes 
     1317     !! 
     1318     !! Method:  
     1319     !!           Sum over relevant grid cells to obtain values 
     1320     !!           for each 
     1321     !!              There are several loops:                  
     1322     !!              loop on the segment between 2 nodes 
     1323     !!              loop on the level jk 
     1324     !!              loop on the density/temperature/salinity/level classes 
     1325     !!              test on the density/temperature/salinity/level 
     1326     !! 
     1327     !!  ** Method  :Transport through a given section is equal to the sum of transports 
     1328     !!              computed on each proc. 
     1329     !!              On each proc,transport is equal to the sum of transport computed through 
     1330     !!              segments linking each point of sec%listPoint  with the next one.    
     1331     !! 
     1332     !!------------------------------------------------------------- 
     1333     !! * arguments 
     1334     TYPE(SECTION),INTENT(INOUT) :: sec 
     1335     INTEGER      ,INTENT(IN)    :: jsec        ! numeric identifier of section 
     1336 
     1337     TYPE(POINT_SECTION) :: k 
     1338     INTEGER  :: jk,jseg,jclass                        !loop on level/segment/classes  
     1339     REAL(wp) :: ztn, zsn, zrhoi, zrhop, zsshn, zfsdep ! temperature/salinity/ssh/potential density /depth at u/v point 
     1340     !!------------------------------------------------------------- 
     1341 
     1342     !! Sum the relevant segments to obtain values for each class 
     1343     IF(sec%nb_point .NE. 0)THEN    
     1344 
     1345        !--------------------------------------! 
     1346        ! LOOP ON THE SEGMENT BETWEEN 2 NODES  ! 
     1347        !--------------------------------------! 
     1348        DO jseg=1,MAX(sec%nb_point-1,0) 
     1349            
     1350           !------------------------------------------------------------------------------------------- 
     1351           ! Select the appropriate coordinate for computing the velocity of the segment 
     1352           ! 
     1353           !                      CASE(0)                                    Case (2) 
     1354           !                      -------                                    -------- 
     1355           !  listPoint(jseg)                 listPoint(jseg+1)       listPoint(jseg)  F(i,j)       
     1356           !      F(i,j)----------V(i+1,j)-------F(i+1,j)                               | 
     1357           !                                                                            | 
     1358           !                                                                            | 
     1359           !                                                                            | 
     1360           !                      Case (3)                                            U(i,j) 
     1361           !                      --------                                              | 
     1362           !                                                                            | 
     1363           !  listPoint(jseg+1) F(i,j+1)                                                | 
     1364           !                        |                                                   | 
     1365           !                        |                                                   | 
     1366           !                        |                                 listPoint(jseg+1) F(i,j-1) 
     1367           !                        |                                             
     1368           !                        |                                             
     1369           !                     U(i,j+1)                                             
     1370           !                        |                                       Case(1)      
     1371           !                        |                                       ------       
     1372           !                        |                                             
     1373           !                        |                 listPoint(jseg+1)             listPoint(jseg)                            
     1374           !                        |                 F(i-1,j)-----------V(i,j) -------f(jseg)                            
     1375           ! listPoint(jseg)     F(i,j) 
     1376           !  
     1377           !------------------------------------------------------------------------------------------- 
     1378 
     1379           SELECT CASE( sec%direction(jseg) ) 
     1380           CASE(0)  ;   k = sec%listPoint(jseg) 
     1381           CASE(1)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I+1,sec%listPoint(jseg)%J) 
     1382           CASE(2)  ;   k = sec%listPoint(jseg) 
     1383           CASE(3)  ;   k = POINT_SECTION(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J+1) 
     1384           END SELECT 
     1385 
     1386           !---------------------------| 
     1387           !     LOOP ON THE LEVEL     | 
     1388           !---------------------------| 
     1389           !Sum of the transport on the vertical  
     1390           DO jk=1,mbathy(k%I,k%J) 
     1391 
     1392              ! compute temperature, salinity, insitu & potential density, ssh and depth at U/V point 
     1393              SELECT CASE( sec%direction(jseg) ) 
     1394              CASE(0,1) 
     1395                 ztn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) 
     1396                 zsn   = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) 
     1397                 zrhop = interp(k%I,k%J,jk,'V',rhop) 
     1398                 zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) 
     1399                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I,k%J+1)    ) * vmask(k%I,k%J,1) 
     1400              CASE(2,3) 
     1401                 ztn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) 
     1402                 zsn   = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) 
     1403                 zrhop = interp(k%I,k%J,jk,'U',rhop) 
     1404                 zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) 
     1405                 zsshn =  0.5*( sshn(k%I,k%J)    + sshn(k%I+1,k%J)    ) * umask(k%I,k%J,1)  
     1406              END SELECT 
     1407 
     1408              zfsdep= gdept(k%I,k%J,jk) 
     1409  
     1410              !------------------------------- 
     1411              !  LOOP ON THE DENSITY CLASSES | 
     1412              !------------------------------- 
     1413              !The computation is made for each density/heat/salt/... class 
     1414              DO jclass=1,MAX(1,sec%nb_class-1) 
     1415 
     1416                 !----------------------------------------------! 
     1417                 !TEST ON THE DENSITY/SALINITY/TEMPERATURE/LEVEL!  
     1418                 !----------------------------------------------! 
     1419  
     1420                 IF ( (                                                    & 
     1421                    ((( zrhop .GE. (sec%zsigp(jclass)+1000.  )) .AND.      & 
     1422                    (   zrhop .LE. (sec%zsigp(jclass+1)+1000. ))) .OR.     & 
     1423                    ( sec%zsigp(jclass) .EQ. 99.)) .AND.                   & 
     1424 
     1425                    ((( zrhoi .GE. (sec%zsigi(jclass) + 1000.  )) .AND.    & 
     1426                    (   zrhoi .LE. (sec%zsigi(jclass+1)+1000. ))) .OR.     & 
     1427                    ( sec%zsigi(jclass) .EQ. 99.)) .AND.                   & 
     1428 
     1429                    ((( zsn .GT. sec%zsal(jclass)) .AND.                   & 
     1430                    (   zsn .LE. sec%zsal(jclass+1))) .OR.                 & 
     1431                    ( sec%zsal(jclass) .EQ. 99.)) .AND.                    & 
     1432 
     1433                    ((( ztn .GE. sec%ztem(jclass)) .AND.                   & 
     1434                    (   ztn .LE. sec%ztem(jclass+1))) .OR.                 & 
     1435                    ( sec%ztem(jclass) .EQ.99.)) .AND.                     & 
     1436 
     1437                    ((( zfsdep .GE. sec%zlay(jclass)) .AND.                & 
     1438                    (   zfsdep .LE. sec%zlay(jclass+1))) .OR.              & 
     1439                    ( sec%zlay(jclass) .EQ. 99. ))                         & 
     1440                                                                   ))   THEN 
     1441 
     1442                    !SUM THE TRANSPORTS FOR EACH CLASSES FOR THE POSITIVE AND NEGATIVE DIRECTIONS 
     1443                    !---------------------------------------------------------------------------- 
     1444                    IF (transports_3d_h(1,jsec,jseg,jk) .GE. 0.0) THEN  
     1445                       sec%transport_h(1,jclass) = sec%transport_h(1,jclass)+transports_3d_h(1,jsec,jseg,jk) 
     1446                    ELSE 
     1447                       sec%transport_h(2,jclass) = sec%transport_h(2,jclass)+transports_3d_h(1,jsec,jseg,jk) 
     1448                    ENDIF 
     1449                    IF( sec%llstrpond )THEN 
     1450 
     1451                       IF( transports_3d_h(1,jsec,jseg,jk) .NE. 0._wp ) THEN 
     1452 
     1453                          IF (transports_3d_h(2,jsec,jseg,jk)/transports_3d_h(1,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1454                             sec%transport_h(3,jclass) = sec%transport_h(3,jclass)+transports_3d_h(2,jsec,jseg,jk)/transports_3d_h(1,jsec,jseg,jk) 
     1455                          ELSE 
     1456                             sec%transport_h(4,jclass) = sec%transport_h(4,jclass)+transports_3d_h(2,jsec,jseg,jk)/transports_3d_h(1,jsec,jseg,jk) 
     1457                          ENDIF 
     1458 
     1459                          IF ( transports_3d_h(3,jsec,jseg,jk)/transports_3d_h(1,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1460                             sec%transport_h(5,jclass) = sec%transport_h(5,jclass)+transports_3d_h(3,jsec,jseg,jk)/transports_3d_h(1,jsec,jseg,jk) 
     1461                          ELSE 
     1462                             sec%transport_h(6,jclass) = sec%transport_h(6,jclass)+transports_3d_h(3,jsec,jseg,jk)/transports_3d_h(1,jsec,jseg,jk) 
     1463                          ENDIF 
     1464 
     1465                       ENDIF 
     1466 
     1467                       IF ( transports_3d_h(4,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1468                          sec%transport_h(7,jclass) = sec%transport_h(7,jclass)+transports_3d_h(4,jsec,jseg,jk) 
     1469                       ELSE 
     1470                          sec%transport_h(8,jclass) = sec%transport_h(8,jclass)+transports_3d_h(4,jsec,jseg,jk) 
     1471                       ENDIF 
     1472 
     1473                       IF ( transports_3d_h(5,jsec,jseg,jk) .GE. 0.0 ) THEN 
     1474                          sec%transport_h( 9,jclass) = sec%transport_h( 9,jclass)+transports_3d_h(5,jsec,jseg,jk) 
     1475                       ELSE 
     1476                          sec%transport_h(10,jclass) = sec%transport_h(10,jclass)+transports_3d_h(5,jsec,jseg,jk) 
     1477                       ENDIF 
     1478 
     1479                    ELSE 
     1480                       sec%transport_h( 3,jclass) = 0._wp 
     1481                       sec%transport_h( 4,jclass) = 0._wp 
     1482                       sec%transport_h( 5,jclass) = 0._wp 
     1483                       sec%transport_h( 6,jclass) = 0._wp 
     1484                       sec%transport_h( 7,jclass) = 0._wp 
     1485                       sec%transport_h( 8,jclass) = 0._wp 
     1486                       sec%transport_h( 9,jclass) = 0._wp 
     1487                       sec%transport_h(10,jclass) = 0._wp 
     1488                    ENDIF 
     1489 
     1490                 ENDIF ! end of test if point is in class 
     1491    
     1492              ENDDO ! end of loop on the classes 
     1493 
     1494           ENDDO ! loop over jk 
     1495 
     1496#if defined key_lim2 || defined key_lim3 
     1497 
     1498           !ICE CASE     
     1499           IF( sec%ll_ice_section )THEN 
     1500 
     1501              IF ( transports_2d_h(1,jsec,jseg) .GE. 0.0 ) THEN 
     1502                 sec%transport_h(11,1) = sec%transport_h(11,1)+transports_2d_h(1,jsec,jseg) 
     1503              ELSE 
     1504                 sec%transport_h(12,1) = sec%transport_h(12,1)+transports_2d_h(1,jsec,jseg) 
     1505              ENDIF 
     1506 
     1507              IF ( transports_2d_h(3,jsec,jseg) .GE. 0.0 ) THEN 
     1508                 sec%transport_h(13,1) = sec%transport_h(13,1)+transports_2d_h(2,jsec,jseg) 
     1509              ELSE 
     1510                 sec%transport_h(14,1) = sec%transport_h(14,1)+transports_2d_h(2,jsec,jseg) 
     1511              ENDIF 
     1512 
     1513           ENDIF !end of ice case 
     1514#endif 
     1515  
     1516        ENDDO !end of loop on the segment 
     1517 
     1518     ELSE  !if sec%nb_point =0 
     1519        sec%transport_h(1:2,:)=0. 
     1520        IF (sec%llstrpond) sec%transport_h(3:10,:)=0. 
     1521        IF (sec%ll_ice_section) sec%transport_h( 11:14,:)=0. 
     1522     ENDIF !end of sec%nb_point =0 case 
     1523 
     1524  END SUBROUTINE dia_dct_sum_h 
     1525  
     1526  SUBROUTINE dia_dct_wri_NOOS(kt,ksec,sec) 
     1527     !!------------------------------------------------------------- 
     1528     !! Write transport output in numdct using NOOS formatting  
     1529     !!  
     1530     !! Purpose: Write  transports in ascii files 
     1531     !!  
     1532     !! Method: 
     1533     !!        1. Write volume transports in "volume_transport" 
     1534     !!           Unit: Sv : area * Velocity / 1.e6  
     1535     !!  
     1536     !!        2. Write heat transports in "heat_transport" 
     1537     !!           Unit: Peta W : area * Velocity * T * rhau * Cp / 1.e15 
     1538     !!  
     1539     !!        3. Write salt transports in "salt_transport" 
     1540     !!           Unit: 10^9 g m^3 / s : area * Velocity * S / 1.e6 
     1541     !! 
     1542     !!-------------------------------------------------------------  
     1543     !!arguments 
     1544     INTEGER, INTENT(IN)          :: kt          ! time-step 
     1545     TYPE(SECTION), INTENT(INOUT) :: sec         ! section to write    
     1546     INTEGER ,INTENT(IN)          :: ksec        ! section number 
     1547 
     1548     !!local declarations 
     1549     INTEGER               :: jclass,ji             ! Dummy loop 
     1550     CHARACTER(len=2)      :: classe             ! Classname  
     1551     REAL(wp)              :: zbnd1,zbnd2        ! Class bounds 
     1552     REAL(wp)              :: zslope             ! section's slope coeff 
     1553     ! 
     1554     REAL(wp), POINTER, DIMENSION(:):: zsumclasses ! 1D workspace  
     1555     !!-------------------------------------------------------------  
     1556     CALL wrk_alloc(nb_type , zsumclasses )   
     1557 
     1558     zsumclasses(:)=0._wp 
     1559     zslope = sec%slopeSection        
     1560 
     1561     WRITE(numdct_NOOS,'(I4,a1,I2,a1,I2,a12,i3,a17,i3,a10,a25)') nyear,'.',nmonth,'.',nday,'   Transect:',ksec-1,'   No. of layers:',sec%nb_class-1,'   Name: ',sec%name 
     1562 
     1563     DO jclass=1,MAX(1,sec%nb_class-1) 
     1564        zsumclasses(1:nb_type)=zsumclasses(1:nb_type)+sec%transport(1:nb_type,jclass) 
     1565     ENDDO 
     1566  
     1567     classe   = 'total   ' 
     1568     zbnd1   = 0._wp 
     1569     zbnd2   = 0._wp 
     1570 
     1571     IF ( zslope .gt. 0._wp .and. zslope .ne. 10000._wp ) THEN 
     1572        WRITE(numdct_NOOS,'(9e12.4E2)') -(zsumclasses( 1)+zsumclasses( 2)), -zsumclasses( 2),-zsumclasses( 1),   & 
     1573                                        -(zsumclasses( 7)+zsumclasses( 8)), -zsumclasses( 8),-zsumclasses( 7),   & 
     1574                                        -(zsumclasses( 9)+zsumclasses(10)), -zsumclasses(10),-zsumclasses( 9) 
     1575     ELSE 
     1576        WRITE(numdct_NOOS,'(9e12.4E2)')   zsumclasses( 1)+zsumclasses( 2) ,  zsumclasses( 1), zsumclasses( 2),   & 
     1577                                          zsumclasses( 7)+zsumclasses( 8) ,  zsumclasses( 7), zsumclasses( 8),   & 
     1578                                          zsumclasses( 9)+zsumclasses(10) ,  zsumclasses( 9), zsumclasses(10) 
     1579     ENDIF  
     1580 
     1581     DO jclass=1,MAX(1,sec%nb_class-1) 
     1582    
     1583        classe   = 'N       ' 
     1584        zbnd1   = 0._wp 
     1585        zbnd2   = 0._wp 
     1586 
     1587        !insitu density classes transports 
     1588        IF( ( sec%zsigi(jclass)   .NE. 99._wp ) .AND. & 
     1589            ( sec%zsigi(jclass+1) .NE. 99._wp )       )THEN 
     1590           classe = 'DI       ' 
     1591           zbnd1 = sec%zsigi(jclass) 
     1592           zbnd2 = sec%zsigi(jclass+1) 
     1593        ENDIF 
     1594        !potential density classes transports 
     1595        IF( ( sec%zsigp(jclass)   .NE. 99._wp ) .AND. & 
     1596            ( sec%zsigp(jclass+1) .NE. 99._wp )       )THEN 
     1597           classe = 'DP      ' 
     1598           zbnd1 = sec%zsigp(jclass) 
     1599           zbnd2 = sec%zsigp(jclass+1) 
     1600        ENDIF 
     1601        !depth classes transports 
     1602        IF( ( sec%zlay(jclass)    .NE. 99._wp ) .AND. & 
     1603            ( sec%zlay(jclass+1)  .NE. 99._wp )       )THEN  
     1604           classe = 'Z       ' 
     1605           zbnd1 = sec%zlay(jclass) 
     1606           zbnd2 = sec%zlay(jclass+1) 
     1607        ENDIF 
     1608        !salinity classes transports 
     1609        IF( ( sec%zsal(jclass) .NE. 99._wp    ) .AND. & 
     1610            ( sec%zsal(jclass+1) .NE. 99._wp  )       )THEN 
     1611           classe = 'S       ' 
     1612           zbnd1 = sec%zsal(jclass) 
     1613           zbnd2 = sec%zsal(jclass+1)    
     1614        ENDIF 
     1615        !temperature classes transports 
     1616        IF( ( sec%ztem(jclass) .NE. 99._wp     ) .AND. & 
     1617            ( sec%ztem(jclass+1) .NE. 99._wp     )       ) THEN 
     1618           classe = 'T       ' 
     1619           zbnd1 = sec%ztem(jclass) 
     1620           zbnd2 = sec%ztem(jclass+1) 
     1621        ENDIF 
     1622                   
     1623        !write volume transport per class 
     1624        IF ( zslope .gt. 0._wp .and. zslope .ne. 10000._wp ) THEN 
     1625           WRITE(numdct_NOOS,'(9e12.4E2)') -(sec%transport( 1,jclass)+sec%transport( 2,jclass)),-sec%transport( 2,jclass),-sec%transport( 1,jclass), & 
     1626                                           -(sec%transport( 7,jclass)+sec%transport( 8,jclass)),-sec%transport( 8,jclass),-sec%transport( 7,jclass), & 
     1627                                           -(sec%transport( 9,jclass)+sec%transport(10,jclass)),-sec%transport(10,jclass),-sec%transport( 9,jclass) 
     1628        ELSE 
     1629           WRITE(numdct_NOOS,'(9e12.4E2)')   sec%transport( 1,jclass)+sec%transport( 2,jclass) , sec%transport( 1,jclass), sec%transport( 2,jclass), & 
     1630                                             sec%transport( 7,jclass)+sec%transport( 8,jclass) , sec%transport( 7,jclass), sec%transport( 8,jclass), & 
     1631                                             sec%transport( 9,jclass)+sec%transport(10,jclass) , sec%transport( 9,jclass), sec%transport(10,jclass) 
     1632        ENDIF 
     1633 
     1634     ENDDO 
     1635 
     1636     CALL wrk_dealloc(nb_type , zsumclasses )   
     1637 
     1638  END SUBROUTINE dia_dct_wri_NOOS 
     1639 
     1640  SUBROUTINE dia_dct_wri_NOOS_h(hr,ksec,sec) 
     1641     !!------------------------------------------------------------- 
     1642     !! As routine dia_dct_wri_NOOS but for hourly output files 
     1643     !! 
     1644     !! Write transport output in numdct using NOOS formatting  
     1645     !!  
     1646     !! Purpose: Write  transports in ascii files 
     1647     !!  
     1648     !! Method: 
     1649     !!        1. Write volume transports in "volume_transport" 
     1650     !!           Unit: Sv : area * Velocity / 1.e6  
     1651     !! 
     1652     !!-------------------------------------------------------------  
     1653     !!arguments 
     1654     INTEGER, INTENT(IN)          :: hr          ! hour 
     1655     TYPE(SECTION), INTENT(INOUT) :: sec         ! section to write    
     1656     INTEGER ,INTENT(IN)          :: ksec        ! section number 
     1657 
     1658     !!local declarations 
     1659     INTEGER               :: jclass,jhr            ! Dummy loop 
     1660     CHARACTER(len=2)      :: classe             ! Classname  
     1661     REAL(wp)              :: zbnd1,zbnd2        ! Class bounds 
     1662     REAL(wp)              :: zslope             ! section's slope coeff 
     1663     ! 
     1664     REAL(wp), POINTER, DIMENSION(:):: zsumclasses ! 1D workspace  
     1665     !!-------------------------------------------------------------  
     1666 
     1667     CALL wrk_alloc(nb_type , zsumclasses )  
     1668 
     1669     zsumclasses(:)=0._wp 
     1670     zslope = sec%slopeSection        
     1671 
     1672     DO jclass=1,MAX(1,sec%nb_class-1) 
     1673        zsumclasses(1:nb_type)=zsumclasses(1:nb_type)+sec%transport_h(1:nb_type,jclass) 
     1674     ENDDO 
     1675  
     1676     !write volume transport per class 
     1677     IF ( zslope .gt. 0._wp .and. zslope .ne. 10000._wp ) THEN 
     1678        z_hr_output(ksec,hr,1)=-(zsumclasses(1)+zsumclasses(2)) 
     1679     ELSE 
     1680        z_hr_output(ksec,hr,1)= (zsumclasses(1)+zsumclasses(2)) 
     1681     ENDIF 
     1682 
     1683     DO jclass=1,MAX(1,sec%nb_class-1) 
     1684        IF ( zslope .gt. 0._wp .and. zslope .ne. 10000._wp ) THEN 
     1685           z_hr_output(ksec,hr,jclass+1)=-(sec%transport_h(1,jclass)+sec%transport_h(2,jclass)) 
     1686        ELSE 
     1687           z_hr_output(ksec,hr,jclass+1)= (sec%transport_h(1,jclass)+sec%transport_h(2,jclass)) 
     1688        ENDIF 
     1689     ENDDO 
     1690 
     1691     IF ( hr .eq. 48._wp ) THEN 
     1692        WRITE(numdct_NOOS_h,'(I4,a1,I2,a1,I2,a12,i3,a17,i3)') nyear,'.',nmonth,'.',nday,'   Transect:',ksec-1,'   No. of layers:',sec%nb_class-1 
     1693        DO jhr=25,48 
     1694           WRITE(numdct_NOOS_h,'(11F12.1)')  z_hr_output(ksec,jhr,1), (z_hr_output(ksec,jhr,jclass+1), jclass=1,MAX(1,10) ) 
     1695        ENDDO 
     1696     ENDIF 
     1697 
     1698     CALL wrk_dealloc(nb_type , zsumclasses ) 
     1699 
     1700  END SUBROUTINE dia_dct_wri_NOOS_h 
     1701 
    8961702  SUBROUTINE dia_dct_wri(kt,ksec,sec) 
    8971703     !!------------------------------------------------------------- 
    … …  
    9171723 
    9181724     !!local declarations 
    919      INTEGER               :: jcl,ji             ! Dummy loop 
     1725     INTEGER               :: jclass             ! Dummy loop 
    9201726     CHARACTER(len=2)      :: classe             ! Classname  
    9211727     REAL(wp)              :: zbnd1,zbnd2        ! Class bounds 
    9221728     REAL(wp)              :: zslope             ! section's slope coeff 
    9231729     ! 
    924      REAL(wp), POINTER, DIMENSION(:):: zsumclass ! 1D workspace  
     1730     REAL(wp), POINTER, DIMENSION(:):: zsumclasses ! 1D workspace  
    9251731     !!-------------------------------------------------------------  
    926      CALL wrk_alloc(nb_type_class , zsumclass )   
    927  
    928      zsumclass(:)=0._wp 
     1732     CALL wrk_alloc(nb_type , zsumclasses )   
     1733 
     1734     zsumclasses(:)=0._wp 
    9291735     zslope = sec%slopeSection        
    930  
    931   
    932      DO jcl=1,MAX(1,sec%nb_class-1) 
    933  
    934         ! Mean computation 
    935         sec%transport(:,jcl)=sec%transport(:,jcl)/(nn_dctwri/nn_dct) 
     1736  
     1737     DO jclass=1,MAX(1,sec%nb_class-1) 
     1738 
    9361739        classe   = 'N       ' 
    9371740        zbnd1   = 0._wp 
    9381741        zbnd2   = 0._wp 
    939         zsumclass(1:nb_type_class)=zsumclass(1:nb_type_class)+sec%transport(1:nb_type_class,jcl) 
     1742        zsumclasses(1:nb_type)=zsumclasses(1:nb_type)+sec%transport(1:nb_type,jclass) 
    9401743 
    9411744    
    9421745        !insitu density classes transports 
    943         IF( ( sec%zsigi(jcl)   .NE. 99._wp ) .AND. & 
    944             ( sec%zsigi(jcl+1) .NE. 99._wp )       )THEN 
     1746        IF( ( sec%zsigi(jclass)   .NE. 99._wp ) .AND. & 
     1747            ( sec%zsigi(jclass+1) .NE. 99._wp )       )THEN 
    9451748           classe = 'DI       ' 
    946            zbnd1 = sec%zsigi(jcl) 
    947            zbnd2 = sec%zsigi(jcl+1) 
     1749           zbnd1 = sec%zsigi(jclass) 
     1750           zbnd2 = sec%zsigi(jclass+1) 
    9481751        ENDIF 
    9491752        !potential density classes transports 
    950         IF( ( sec%zsigp(jcl)   .NE. 99._wp ) .AND. & 
    951             ( sec%zsigp(jcl+1) .NE. 99._wp )       )THEN 
     1753        IF( ( sec%zsigp(jclass)   .NE. 99._wp ) .AND. & 
     1754            ( sec%zsigp(jclass+1) .NE. 99._wp )       )THEN 
    9521755           classe = 'DP      ' 
    953            zbnd1 = sec%zsigp(jcl) 
    954            zbnd2 = sec%zsigp(jcl+1) 
     1756           zbnd1 = sec%zsigp(jclass) 
     1757           zbnd2 = sec%zsigp(jclass+1) 
    9551758        ENDIF 
    9561759        !depth classes transports 
    957         IF( ( sec%zlay(jcl)    .NE. 99._wp ) .AND. & 
    958             ( sec%zlay(jcl+1)  .NE. 99._wp )       )THEN  
     1760        IF( ( sec%zlay(jclass)    .NE. 99._wp ) .AND. & 
     1761            ( sec%zlay(jclass+1)  .NE. 99._wp )       )THEN  
    9591762           classe = 'Z       ' 
    960            zbnd1 = sec%zlay(jcl) 
    961            zbnd2 = sec%zlay(jcl+1) 
     1763           zbnd1 = sec%zlay(jclass) 
     1764           zbnd2 = sec%zlay(jclass+1) 
    9621765        ENDIF 
    9631766        !salinity classes transports 
    964         IF( ( sec%zsal(jcl) .NE. 99._wp    ) .AND. & 
    965             ( sec%zsal(jcl+1) .NE. 99._wp  )       )THEN 
     1767        IF( ( sec%zsal(jclass) .NE. 99._wp    ) .AND. & 
     1768            ( sec%zsal(jclass+1) .NE. 99._wp  )       )THEN 
    9661769           classe = 'S       ' 
    967            zbnd1 = sec%zsal(jcl) 
    968            zbnd2 = sec%zsal(jcl+1)    
     1770           zbnd1 = sec%zsal(jclass) 
     1771           zbnd2 = sec%zsal(jclass+1)    
    9691772        ENDIF 
    9701773        !temperature classes transports 
    971         IF( ( sec%ztem(jcl) .NE. 99._wp     ) .AND. & 
    972             ( sec%ztem(jcl+1) .NE. 99._wp     )       ) THEN 
     1774        IF( ( sec%ztem(jclass) .NE. 99._wp     ) .AND. & 
     1775            ( sec%ztem(jclass+1) .NE. 99._wp     )       ) THEN 
    9731776           classe = 'T       ' 
    974            zbnd1 = sec%ztem(jcl) 
    975            zbnd2 = sec%ztem(jcl+1) 
     1777           zbnd1 = sec%ztem(jclass) 
     1778           zbnd2 = sec%ztem(jclass+1) 
    9761779        ENDIF 
    9771780                   
    9781781        !write volume transport per class 
    9791782        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & 
    980                               jcl,classe,zbnd1,zbnd2,& 
    981                               sec%transport(1,jcl),sec%transport(2,jcl), & 
    982                               sec%transport(1,jcl)+sec%transport(2,jcl) 
     1783                              jclass,classe,zbnd1,zbnd2,& 
     1784                              sec%transport(1,jclass),sec%transport(2,jclass), & 
     1785                              sec%transport(1,jclass)+sec%transport(2,jclass) 
    9831786 
    9841787        IF( sec%llstrpond )THEN 
    9851788 
    9861789           !write heat transport per class: 
    987            WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope,  & 
    988                               jcl,classe,zbnd1,zbnd2,& 
    989                               sec%transport(7,jcl)*1000._wp*rcp/1.e15,sec%transport(8,jcl)*1000._wp*rcp/1.e15, & 
    990                               ( sec%transport(7,jcl)+sec%transport(8,jcl) )*1000._wp*rcp/1.e15 
     1790           WRITE(numdct_temp,119) ndastp,kt,ksec,sec%name,zslope,  & 
     1791                              jclass,classe,zbnd1,zbnd2,& 
     1792                              sec%transport(7,jclass)*1000._wp*rcp/1.e15,sec%transport(8,jclass)*1000._wp*rcp/1.e15, & 
     1793                              ( sec%transport(7,jclass)+sec%transport(8,jclass) )*1000._wp*rcp/1.e15 
    9911794           !write salt transport per class 
    992            WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope,  & 
    993                               jcl,classe,zbnd1,zbnd2,& 
    994                               sec%transport(9,jcl)*1000._wp/1.e9,sec%transport(10,jcl)*1000._wp/1.e9,& 
    995                               (sec%transport(9,jcl)+sec%transport(10,jcl))*1000._wp/1.e9 
     1795           WRITE(numdct_sal ,119) ndastp,kt,ksec,sec%name,zslope,  & 
     1796                              jclass,classe,zbnd1,zbnd2,& 
     1797                              sec%transport(9,jclass)*1000._wp/1.e9,sec%transport(10,jclass)*1000._wp/1.e9,& 
     1798                              (sec%transport(9,jclass)+sec%transport(10,jclass))*1000._wp/1.e9 
    9961799        ENDIF 
    9971800 
    … …  
    10001803     zbnd1 = 0._wp 
    10011804     zbnd2 = 0._wp 
    1002      jcl=0 
     1805     jclass=0 
    10031806 
    10041807     !write total volume transport 
    10051808     WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope, & 
    1006                            jcl,"total",zbnd1,zbnd2,& 
    1007                            zsumclass(1),zsumclass(2),zsumclass(1)+zsumclass(2) 
     1809                           jclass,"total",zbnd1,zbnd2,& 
     1810                           zsumclasses(1),zsumclasses(2),zsumclasses(1)+zsumclasses(2) 
    10081811 
    10091812     IF( sec%llstrpond )THEN 
    10101813 
    10111814        !write total heat transport 
    1012         WRITE(numdct_heat,119) ndastp,kt,ksec,sec%name,zslope, & 
    1013                            jcl,"total",zbnd1,zbnd2,& 
    1014                            zsumclass(7)* 1000._wp*rcp/1.e15,zsumclass(8)* 1000._wp*rcp/1.e15,& 
    1015                            (zsumclass(7)+zsumclass(8) )* 1000._wp*rcp/1.e15 
     1815        WRITE(numdct_temp,119) ndastp,kt,ksec,sec%name,zslope, & 
     1816                           jclass,"total",zbnd1,zbnd2,& 
     1817                           zsumclasses(7)* 1000._wp*rcp/1.e15,zsumclasses(8)* 1000._wp*rcp/1.e15,& 
     1818                           (zsumclasses(7)+zsumclasses(8) )* 1000._wp*rcp/1.e15 
    10161819        !write total salt transport 
    1017         WRITE(numdct_salt,119) ndastp,kt,ksec,sec%name,zslope, & 
    1018                            jcl,"total",zbnd1,zbnd2,& 
    1019                            zsumclass(9)*1000._wp/1.e9,zsumclass(10)*1000._wp/1.e9,& 
    1020                            (zsumclass(9)+zsumclass(10))*1000._wp/1.e9 
     1820        WRITE(numdct_sal ,119) ndastp,kt,ksec,sec%name,zslope, & 
     1821                           jclass,"total",zbnd1,zbnd2,& 
     1822                           zsumclasses(9)*1000._wp/1.e9,zsumclasses(10)*1000._wp/1.e9,& 
     1823                           (zsumclasses(9)+zsumclasses(10))*1000._wp/1.e9 
    10211824     ENDIF 
    10221825 
    … …  
    10251828        !write total ice volume transport 
    10261829        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& 
    1027                               jcl,"ice_vol",zbnd1,zbnd2,& 
    1028                               sec%transport(9,1),sec%transport(10,1),& 
    1029                               sec%transport(9,1)+sec%transport(10,1) 
     1830                              jclass,"ice_vol",zbnd1,zbnd2,& 
     1831                              sec%transport(11,1),sec%transport(12,1),& 
     1832                              sec%transport(11,1)+sec%transport(12,1) 
    10301833        !write total ice surface transport 
    10311834        WRITE(numdct_vol,118) ndastp,kt,ksec,sec%name,zslope,& 
    1032                               jcl,"ice_surf",zbnd1,zbnd2,& 
    1033                               sec%transport(11,1),sec%transport(12,1), & 
    1034                               sec%transport(11,1)+sec%transport(12,1)  
     1835                              jclass,"ice_surf",zbnd1,zbnd2,& 
     1836                              sec%transport(13,1),sec%transport(14,1), & 
     1837                              sec%transport(13,1)+sec%transport(14,1)  
    10351838     ENDIF 
    10361839                                               
    … …  
    10381841119 FORMAT(I8,1X,I8,1X,I4,1X,A30,1X,f9.2,1X,I4,3X,A8,1X,2F12.4,5X,3E15.6) 
    10391842 
    1040      CALL wrk_dealloc(nb_type_class , zsumclass )   
     1843     CALL wrk_dealloc(nb_type , zsumclasses )   
    10411844  END SUBROUTINE dia_dct_wri 
    10421845 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r7363 r7367  
    332332      !!---------------------------------------------------------------------- 
    333333      USE oce,     vt  =>   ua   ! use ua as workspace 
    334       USE oce,     vs  =>   ua   ! use ua as workspace 
     334      USE oce,     vs  =>   va   ! use va as workspace 
    335335      IMPLICIT none 
    336336      !! 
    … …  
    378378                     zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 
    379379#endif  
    380                      vt(:,jj,jk) = zv * tsn(:,jj,jk,jp_tem) 
    381                      vs(:,jj,jk) = zv * tsn(:,jj,jk,jp_sal) 
     380                     vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem) 
     381                     vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal) 
    382382                  END DO 
    383383               END DO 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r7363 r7367  
    4444   USE iom 
    4545   USE ioipsl 
     46   USE diafoam, ONLY: dia_wri_foam  
     47!CEOD   USE insitu_tem, ONLY: insitu_t, theta2t 
     48   USE bartrop_uv, ONLY: un_dm, vn_dm, bartrop_vel 
    4649#if defined key_lim2 
    4750   USE limwri_2  
     51   USE ice_2           ! LIM_2 ice model variables 
     52   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     53#endif 
     54#if defined key_lim3 
     55   USE ice_3           ! LIM_3 ice model variables 
     56   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     57#endif 
     58   USE daymod          ! calendar 
     59   USE insitu_tem, ONLY: insitu_t, theta2t 
     60#if defined key_top  
     61   USE par_trc         ! biogeochemical variables  
     62   USE trc 
     63#endif 
     64#if defined key_spm 
     65   USE spm_con, ONLY:  Eps0XS  
     66#endif  
     67#if defined key_zdftke  
     68   USE zdftke, ONLY: en 
     69#endif 
     70   USE zdf_oce, ONLY: avt, avm 
     71#if defined key_zdfgls 
     72   USE zdfgls, ONLY: mxln, en 
    4873#endif 
    4974   USE lib_mpp         ! MPP library 
    … …  
    5479   PRIVATE 
    5580 
     81   PUBLIC   dia_wri_tmb_init        ! Called by nemogcm module 
    5682   PUBLIC   dia_wri                 ! routines called by step.F90 
    5783   PUBLIC   dia_wri_state 
    5884   PUBLIC   dia_wri_alloc           ! Called by nemogcm module 
     85   PUBLIC   dia_wri_tide_init       ! Called by nemogcm module 
    5986 
    6087   INTEGER ::   nid_T, nz_T, nh_T, ndim_T, ndim_hT   ! grid_T file 
    … …  
    6592   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV 
    6693   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V 
     94 
     95   !! * variables for calculating 25-hourly means 
     96   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:,:) ::   tn_25h  , sn_25h  , insitu_t_25h 
     97   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:)   ::   sshn_25h, hmld_kara_25h 
     98   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:,:) ::   un_25h  , vn_25h  , wn_25h 
     99   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:,:) ::   avt_25h , avm_25h 
     100#if defined key_zdfgls || key_zdftke 
     101   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:,:) ::   en_25h   
     102#endif 
     103#if defined key_zdfgls  
     104   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:,:) ::   mxln_25h 
     105#endif 
     106   INTEGER, SAVE :: cnt_25h     ! Counter for 25 hour means 
     107 
     108 
    67109 
    68110   !! * Substitutions 
    … …  
    125167      REAL(wp), POINTER, DIMENSION(:,:)   :: z2d       ! 2D workspace 
    126168      REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d      ! 3D workspace 
     169      REAL(wp), POINTER, DIMENSION(:,:,:) :: zwtmb    ! temporary workspace for tmb 
    127170      !!---------------------------------------------------------------------- 
    128171      !  
    … …  
    131174      CALL wrk_alloc( jpi , jpj      , z2d ) 
    132175      CALL wrk_alloc( jpi , jpj, jpk , z3d ) 
     176      CALL wrk_alloc( jpi , jpj, 3 , zwtmb ) 
    133177      ! 
    134178      ! Output the initial state and forcings 
    … …  
    138182      ENDIF 
    139183 
     184      IF (ln_diatide) THEN 
     185         CALL dia_wri_tide(kt) 
     186      ENDIF 
     187 
    140188      CALL iom_put( "toce"   , tsn(:,:,:,jp_tem)                     )    ! temperature 
     189      CALL theta2t ! in-situ temperature conversion 
     190!CEOD      CALL iom_put( "tinsitu", insitu_t(:,:,:)                       )    ! in-situ temperature 
    141191      CALL iom_put( "soce"   , tsn(:,:,:,jp_sal)                     )    ! salinity 
    142192      CALL iom_put( "sst"    , tsn(:,:,1,jp_tem)                     )    ! sea surface temperature 
    … …  
    146196      CALL iom_put( "uoce"   , un                                    )    ! i-current       
    147197      CALL iom_put( "voce"   , vn                                    )    ! j-current 
    148        
     198      CALL iom_put( "ssu"    , un(:,:,1)                             )    ! sea surface U velocity 
     199      CALL iom_put( "ssv"    , vn(:,:,1)                             )    ! sea surface V velocity 
     200      IF( cp_cfg == "natl" .OR. cp_cfg == "ind12" ) CALL bartrop_vel ! barotropic velocity conversion 
     201!These don't exist independently in this branch so we remove them to get a CO5 
     202!that works on the Cray  
     203!CEOD      CALL iom_put( "uocebt" , un_dm                                 )    ! barotropic i-current  
     204!CEOD      CALL iom_put( "vocebt" , vn_dm                                 )    ! barotropic j-current 
    149205      CALL iom_put( "avt"    , avt                                   )    ! T vert. eddy diff. coef. 
    150206      CALL iom_put( "avm"    , avmu                                  )    ! T vert. eddy visc. coef. 
    151207      IF( lk_zdfddm ) THEN 
    152208         CALL iom_put( "avs" , fsavs(:,:,:)                          )    ! S vert. eddy diff. coef. 
     209      ENDIF 
     210      ! 
     211      ! If we want tmb values  
     212 
     213      IF (ln_diatmb) THEN 
     214         CALL dia_wri_calctmb(  tsn(:,:,:,jp_tem),zwtmb )  
     215         !ssh already output but here we output it masked 
     216         CALL iom_put( "sshnmasked" , sshn(:,:)*tmask(:,:,1)+missing_val*(1-tmask(:,:,1 ) ) )   ! tmb Temperature 
     217         CALL iom_put( "top_temp" , zwtmb(:,:,1) )    ! tmb Temperature 
     218         CALL iom_put( "mid_temp" , zwtmb(:,:,2) )    ! tmb Temperature 
     219         CALL iom_put( "bot_temp" , zwtmb(:,:,3) )    ! tmb Temperature 
     220!         CALL iom_put( "sotrefml" , hmld_tref(:,:) )    ! "T criterion Mixed Layer Depth 
     221 
     222         CALL dia_wri_calctmb(  tsn(:,:,:,jp_sal),zwtmb )  
     223         CALL iom_put( "top_sal" , zwtmb(:,:,1) )    ! tmb Salinity  
     224         CALL iom_put( "mid_sal" , zwtmb(:,:,2) )    ! tmb Salinity 
     225         CALL iom_put( "bot_sal" , zwtmb(:,:,3) )    ! tmb Salinity 
     226 
     227         CALL dia_wri_calctmb(  un(:,:,:),zwtmb )  
     228         CALL iom_put( "top_u" , zwtmb(:,:,1) )    ! tmb  U Velocity 
     229         CALL iom_put( "mid_u" , zwtmb(:,:,2) )    ! tmb  U Velocity 
     230         CALL iom_put( "bot_u" , zwtmb(:,:,3) )    ! tmb  U Velocity 
     231!Called in  dynspg_ts.F90        CALL iom_put( "baro_u" , un_b )    ! Barotropic  U Velocity 
     232 
     233         CALL dia_wri_calctmb(  vn(:,:,:),zwtmb )  
     234         CALL iom_put( "top_v" , zwtmb(:,:,1) )    ! tmb  V Velocity 
     235         CALL iom_put( "mid_v" , zwtmb(:,:,2) )    ! tmb  V Velocity 
     236         CALL iom_put( "bot_v" , zwtmb(:,:,3) )    ! tmb  V Velocity 
     237!Called in  dynspg_ts.F90       CALL iom_put( "baro_v" , vn_b )    ! Barotropic  V Velocity 
    153238      ENDIF 
    154239 
    … …  
    171256         z3d(:,:,jpk) = 0.e0 
    172257         DO jk = 1, jpkm1 
    173             z3d(:,:,jk) = rau0 * un(:,:,jk) * e1u(:,:) * fse3u(:,:,jk) 
     258            z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) 
    174259         END DO 
    175260         CALL iom_put( "u_masstr", z3d )                  ! mass transport in i-direction 
    … …  
    186271         CALL iom_put( "u_heattr", z2d )                  ! heat transport in i-direction 
    187272         DO jk = 1, jpkm1 
    188             z3d(:,:,jk) = rau0 * vn(:,:,jk) * e2v(:,:) * fse3v(:,:,jk) 
     273            z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) 
    189274         END DO 
    190275         CALL iom_put( "v_masstr", z3d )                  ! mass transport in j-direction 
    … …  
    251336      ENDIF 
    252337      ! 
     338      ! -1. Alternative routine  
     339      !------------------------  
     340      IF (ln_diafoam) THEN  
     341         CALL dia_wri_foam( kt )  
     342         RETURN  
     343      END IF  
     344      !  
    253345      ! 0. Initialisation 
    254346      ! ----------------- 
    … …  
    673765#endif 
    674766 
     767   SUBROUTINE dia_wri_calctmb( infield,outtmb ) 
     768      !!--------------------------------------------------------------------- 
     769      !!                  ***  ROUTINE dia_tmb  *** 
     770      !!                    
     771      !! ** Purpose :   Write diagnostics for Top,Mid, and Bottom of water Column 
     772      !! 
     773      !! ** Method  :    
     774      !!      use mbathy to find surface, mid and bottom of model levels 
     775      !! 
     776      !! History : 
     777      !!   3.4  !  04-13  (E. O'Dea) Routine taken from old dia_wri_foam 
     778      !!---------------------------------------------------------------------- 
     779      !! * Modules used 
     780 
     781      ! Routine to map 3d field to top, middle, bottom 
     782      IMPLICIT NONE 
     783 
     784      ! Routine arguments 
     785      REAL(wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: infield    ! Input 3d field and mask 
     786      REAL(wp), DIMENSION(jpi, jpj, 3  ), INTENT(  OUT) :: outtmb     ! Output top, middle, bottom 
     787 
     788      ! Local variables 
     789      INTEGER :: ji,jj,jk  ! Dummy loop indices 
     790 
     791      ! Calculate top 
     792      outtmb(:,:,1) = infield(:,:,1)*tmask(:,:,1) + missing_val*(1-tmask(:,:,1)) 
     793 
     794      ! Calculate middle 
     795      DO ji = 1,jpi 
     796         DO jj = 1,jpj 
     797            jk              = max(1,mbathy(ji,jj)/2) 
     798            outtmb(ji,jj,2) = infield(ji,jj,jk)*tmask(ji,jj,jk) + missing_val*(1-tmask(ji,jj,jk)) 
     799         END DO 
     800      END DO 
     801 
     802      ! Calculate bottom 
     803      DO ji = 1,jpi 
     804         DO jj = 1,jpj 
     805            jk              = max(1,mbathy(ji,jj) - 1) 
     806            outtmb(ji,jj,3) = infield(ji,jj,jk)*tmask(ji,jj,jk)  + missing_val*(1-tmask(ji,jj,jk)) 
     807         END DO 
     808      END DO 
     809 
     810   END SUBROUTINE dia_wri_calctmb 
     811 
     812   SUBROUTINE dia_wri_tmb_init 
     813      !!--------------------------------------------------------------------------- 
     814      !!                  ***  ROUTINE dia_wri_tmb_init  *** 
     815      !!      
     816      !! ** Purpose: Initialization of tmb namelist  
     817      !!         
     818      !! ** Method : Read namelist 
     819      !!   History 
     820      !!   3.4  !  04-13  (E. O'Dea) Routine to initialize dia_wri_tmb 
     821      !!--------------------------------------------------------------------------- 
     822      !! 
     823      INTEGER            ::   ierror   ! local integer 
     824      !! 
     825      NAMELIST/nam_diatmb/ ln_diatmb 
     826      !! 
     827      !!---------------------------------------------------------------------- 
     828      ! 
     829      REWIND ( numnam )              ! Read Namelist nam_diatmb 
     830      READ   ( numnam, nam_diatmb ) 
     831      ! 
     832      IF(lwp) THEN                   ! Control print 
     833         WRITE(numout,*) 
     834         WRITE(numout,*) 'dia_wri_tmb_init : Output Top, Middle, Bottom Diagnostics' 
     835         WRITE(numout,*) '~~~~~~~~~~~~' 
     836         WRITE(numout,*) '   Namelist nam_diatmb : set tmb outputs ' 
     837         WRITE(numout,*) '      Switch for TMB diagnostics (T) or not (F)  ln_diatmb  = ', ln_diatmb 
     838      ENDIF 
     839 
     840    END SUBROUTINE dia_wri_tmb_init 
     841 
     842 
    675843   SUBROUTINE dia_wri_state( cdfile_name, kt ) 
    676844      !!--------------------------------------------------------------------- 
    … …  
    798966   END SUBROUTINE dia_wri_state 
    799967   !!====================================================================== 
     968   !!====================================================================== 
     969 
     970   SUBROUTINE dia_wri_tide( kt ) 
     971      !!--------------------------------------------------------------------- 
     972      !!                  ***  ROUTINE dia_tide  *** 
     973      !!                    
     974      !! ** Purpose :   Write diagnostics with M2/S2 tide removed 
     975      !! 
     976      !! ** Method  :    
     977      !!      25hr mean outputs for shelf seas 
     978      !! 
     979      !! History : 
     980      !!   ?.0  !  07-04  (A. Hines) New routine, developed from dia_wri_foam 
     981      !!   3.4  !  02-13  (J. Siddorn) Routine taken from old dia_wri_foam 
     982      !!---------------------------------------------------------------------- 
     983      !! * Modules used 
     984 
     985      IMPLICIT NONE 
     986 
     987      !! * Arguments 
     988      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
     989 
     990 
     991      !! * Local declarations 
     992      INTEGER ::   ji, jj, jk 
     993 
     994      LOGICAL ::   ll_print = .FALSE.    ! =T print and flush numout 
     995      REAL(wp)                         ::   zsto, zout, zmax, zjulian, zdt, zmdi  ! temporary integers 
     996      INTEGER                          ::   i_steps                               ! no of timesteps per hour 
     997      REAL(wp), DIMENSION(jpi,jpj    ) ::   zw2d, un_dm, vn_dm                    ! temporary workspace 
     998      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d                                  ! temporary workspace 
     999      REAL(wp), DIMENSION(jpi,jpj,3)   ::   zwtmb                                 ! temporary workspace 
     1000      INTEGER                          ::   nyear0, nmonth0,nday0                 ! start year,month,day 
     1001!#if defined key_top 
     1002!      CHARACTER (len=20) :: cltra, cltrau 
     1003!      CHARACTER (len=80) :: cltral 
     1004!      INTEGER            :: jn, jl 
     1005!#endif 
     1006!#if defined key_spm   
     1007!      ! variables needed to calculate visibility field from sediment fields 
     1008!      REAL(wp), DIMENSION(jpi,jpj,jpk) :: vis3d    ! derived 3D visibility field 
     1009!      REAL(wp) :: epsessX = 0.07d-03               ! attenuation coefficient applied to the sediment (as used in ERSEM) 
     1010!      REAL(wp) :: tiny = 1.0d-15                   ! to prevent division by zero in visibility calculation 
     1011!#endif    
     1012         
     1013      !!---------------------------------------------------------------------- 
     1014      
     1015      ! 0. Initialisation 
     1016      ! ----------------- 
     1017      ! Define frequency of summing to create 25 h mean 
     1018      zdt = rdt 
     1019      IF( nacc == 1 ) zdt = rdtmin 
     1020       
     1021      IF( MOD( 3600,INT(zdt) ) == 0 ) THEN 
     1022         i_steps = 3600/INT(zdt) 
     1023      ELSE 
     1024         CALL ctl_stop('STOP', 'dia_wri_tide: timestep must give MOD(3600,rdt) = 0 otherwise no hourly values are possible') 
     1025      ENDIF  
     1026           
     1027#if defined key_lim3 || defined key_lim2 
     1028      CALL ctl_stop('STOP', 'dia_wri_tide not setup yet to do tidemean ice') 
     1029#endif 
     1030#if defined key_spm || defined key_MOersem 
     1031      CALL ctl_stop('STOP', 'dia_wri_tide not setup yet to do tidemean ERSEM') 
     1032#endif 
     1033                
     1034      ! local variable for debugging 
     1035      ll_print = ll_print .AND. lwp 
     1036 
     1037      ! Sum of 25 hourly instantaneous values to give a 25h mean from 24hours 
     1038      ! every day 
     1039      IF( MOD( kt, i_steps ) == 0  .and. kt .ne. nn_it000 ) THEN 
     1040 
     1041         IF (lwp) THEN 
     1042              WRITE(numout,*) 'dia_wri_tide : Summing instantaneous hourly diagnostics at timestep ',kt 
     1043              WRITE(numout,*) '~~~~~~~~~~~~ ' 
     1044         ENDIF 
     1045 
     1046         tn_25h(:,:,:)        = tn_25h(:,:,:) + tsn(:,:,:,jp_tem) 
     1047         sn_25h(:,:,:)        = sn_25h(:,:,:) + tsn(:,:,:,jp_sal) 
     1048         CALL theta2t 
     1049         insitu_t_25h(:,:,:)  = insitu_t_25h(:,:,:) + insitu_t(:,:,:) 
     1050         sshn_25h(:,:)        = sshn_25h(:,:) + sshn (:,:) 
     1051!         hmld_kara_25h(:,:)   = hmld_kara_25h(:,:) + hmld_kara(:,:) 
     1052#if defined key_lim3 || defined key_lim2 
     1053         hsnif_25h(:,:)       = hsnif_25h(:,:) + hsnif(:,:) 
     1054         hicif_25h(:,:)       = hicif_25h(:,:) + hicif(:,:) 
     1055         frld_25h(:,:)        = frld_25h(:,:) + frld(:,:) 
     1056#endif  
     1057#if defined key_spm || defined key_MOersem 
     1058         trn_25h(:,:,:,:)     = trn_25h(:,:,:,:) + trn (:,:,:,:) 
     1059         trc3d_25h(:,:,:,:)   = trc3d_25h(:,:,:,:) + trc3d(:,:,:,:) 
     1060         trc2d_25h(:,:,:)     = trc2d_25h(:,:,:) + trc2d(:,:,:) 
     1061#endif 
     1062         un_25h(:,:,:)        = un_25h(:,:,:) + un(:,:,:) 
     1063         vn_25h(:,:,:)        = vn_25h(:,:,:) + vn(:,:,:) 
     1064         wn_25h(:,:,:)        = wn_25h(:,:,:) + wn(:,:,:) 
     1065         avt_25h(:,:,:)       = avt_25h(:,:,:) + avt(:,:,:) 
     1066         avm_25h(:,:,:)       = avm_25h(:,:,:) + avm(:,:,:) 
     1067# if defined key_zdfgls || defined key_zdftke 
     1068         en_25h(:,:,:)        = en_25h(:,:,:) + en(:,:,:) 
     1069#endif 
     1070# if defined key_zdfgls 
     1071         mxln_25h(:,:,:)      = mxln_25h(:,:,:) + mxln(:,:,:) 
     1072#endif 
     1073         cnt_25h = cnt_25h + 1 
     1074 
     1075         IF (lwp) THEN 
     1076            WRITE(numout,*) 'dia_tide : Summed the following number of hourly values so far',cnt_25h 
     1077         ENDIF 
     1078 
     1079      ENDIF ! MOD( kt, i_steps ) == 0 
     1080 
     1081         ! Write data for 25 hour mean output streams 
     1082      IF( cnt_25h .EQ. 25 .AND.  MOD( kt, i_steps*24) == 0 .AND. kt .NE. nn_it000 ) THEN 
     1083 
     1084            IF(lwp) THEN 
     1085               WRITE(numout,*) 'dia_wri_tide : Writing 25 hour mean tide diagnostics at timestep', kt 
     1086               WRITE(numout,*) '~~~~~~~~~~~~ ' 
     1087            ENDIF 
     1088 
     1089            tn_25h(:,:,:)        = tn_25h(:,:,:) / 25.0_wp 
     1090            sn_25h(:,:,:)        = sn_25h(:,:,:) / 25.0_wp 
     1091            insitu_t_25h(:,:,:)  = insitu_t_25h(:,:,:) / 25.0_wp 
     1092            sshn_25h(:,:)        = sshn_25h(:,:) / 25.0_wp 
     1093!            hmld_kara_25h(:,:)   = hmld_kara_25h(:,:) / 25.0_wp 
     1094#if defined key_lim3 || defined key_lim2 
     1095            hsnif_25h(:,:)       = hsnif_25h(:,:) / 25.0_wp 
     1096            hicif_25h(:,:)       = hicif_25h(:,:) / 25.0_wp 
     1097            frld_25h(:,:)        = frld_25h(:,:) / 25.0_wp 
     1098#endif  
     1099#if defined key_spm || defined key_MOersem 
     1100            trn_25h(:,:,:,:)     = trn_25h(:,:,:,:) / 25.0_wp 
     1101            trc3d_25h(:,:,:,:)   = trc3d_25h(:,:,:,:) / 25.0_wp 
     1102            trc2d_25h(:,:,:)     = trc2d_25h(:,:,:) / 25.0_wp 
     1103#endif 
     1104            un_25h(:,:,:)        = un_25h(:,:,:) / 25.0_wp 
     1105            vn_25h(:,:,:)        = vn_25h(:,:,:) / 25.0_wp 
     1106            wn_25h(:,:,:)        = wn_25h(:,:,:) / 25.0_wp 
     1107            avt_25h(:,:,:)       = avt_25h(:,:,:) / 25.0_wp 
     1108            avm_25h(:,:,:)       = avm_25h(:,:,:) / 25.0_wp 
     1109# if defined key_zdfgls || defined key_zdftke 
     1110            en_25h(:,:,:)        = en_25h(:,:,:) / 25.0_wp 
     1111#endif 
     1112# if defined key_zdfgls 
     1113            mxln_25h(:,:,:)       = mxln_25h(:,:,:) / 25.0_wp 
     1114#endif 
     1115 
     1116            IF (lwp)  WRITE(numout,*) 'dia_wri_tide : Mean calculated by dividing 25 hour sums and writing output'  
     1117  
     1118            zmdi=missing_val                 ! for masking 
     1119            ! write tracers (instantaneous) 
     1120            zw3d(:,:,:) = tn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1121            CALL iom_put("temper25h", zw3d)   ! potential temperature 
     1122            CALL theta2t                                                                    ! calculate insitu temp 
     1123            zw3d(:,:,:) = insitu_t_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1124            CALL iom_put("tempis25h", zw3d)   ! in-situ temperature 
     1125            zw3d(:,:,:) = sn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1126            CALL iom_put( "salin25h", zw3d  )   ! salinity 
     1127            zw2d(:,:) = sshn_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     1128            CALL iom_put( "ssh25h", zw2d )   ! sea surface  
     1129!            zw2d(:,:) = hmld_kara_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     1130!            CALL iom_put( "kara25h", zw2d )   ! mixed layer  
     1131 
     1132#if defined key_lim3 || defined key_lim2 
     1133            ! Write ice model variables (instantaneous) 
     1134            zw2d(:,:) = hsnif_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     1135            CALL iom_put("isnowthi", zw2d )   ! ice thickness 
     1136            zw2d(:,:) = hicif_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     1137            CALL iom_put("iicethic", zw2d )   ! ice thickness 
     1138            zw2d(:,:) = (1.0-frld_25h(:,:))*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     1139            CALL iom_put("iiceconc", zw2d )   ! ice concetration 
     1140#endif 
     1141#if defined key_spm || key_MOersem 
     1142            ! output biogeochemical variables: 
     1143            ! output main tracers 
     1144            DO jn = 1, jptra 
     1145               cltra = ctrcnm(jn)      ! short title for tracer 
     1146               zw3d(:,:,:) = trn_25h(:,:,:,jn)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1147               IF( lutsav(jn) )  CALL iom_put( cltra, zw3d  )   ! temperature 
     1148            END DO 
     1149            ! more 3D horizontal arrays from diagnostics 
     1150            DO jl = 1, jpdia3d 
     1151               cltra = ctrc3d(jl)   ! short title for 3D diagnostic 
     1152               zw3d(:,:,:) = trc3d_25h(:,:,:,jl)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1153               CALL iom_put( cltra, zw3d  )    
     1154            END DO 
     1155            ! more 2D horizontal arrays from diagnostics 
     1156            DO jl = 1, jpdia2d 
     1157               cltra = ctrc2d(jl)   ! short title for 2D diagnostic 
     1158               zw2d(:,:) = trc2d_25h(:,:,jl)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) 
     1159               CALL iom_put(cltra, zw2d ) 
     1160            END DO 
     1161#endif 
     1162 
     1163            ! Write velocities (instantaneous) 
     1164            zw3d(:,:,:) = un_25h(:,:,:)*umask(:,:,:) + zmdi*(1.0-umask(:,:,:)) 
     1165            CALL iom_put("vozocrtx25h", zw3d)    ! i-current 
     1166            zw3d(:,:,:) = vn_25h(:,:,:)*vmask(:,:,:) + zmdi*(1.0-vmask(:,:,:)) 
     1167            CALL iom_put("vomecrty25h", zw3d  )   ! j-current 
     1168 
     1169            zw3d(:,:,:) = wn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1170            CALL iom_put("vomecrtz25h", zw3d )   ! k-current 
     1171            zw3d(:,:,:) = avt_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1172            CALL iom_put("avt25h", zw3d )   ! diffusivity 
     1173            zw3d(:,:,:) = avm_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1174            CALL iom_put("avm25h", zw3d)   ! viscosity 
     1175#if defined key_zdftke || defined key_zdfgls  
     1176            zw3d(:,:,:) = en_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1177            CALL iom_put("tke25h", zw3d)   ! tke 
     1178#endif 
     1179#if defined key_zdfgls  
     1180            zw3d(:,:,:) = mxln_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) 
     1181            CALL iom_put( "mxln25h",zw3d)  
     1182#endif 
     1183 
     1184            ! After the write reset the values to cnt=1 and sum values equal current value  
     1185            tn_25h(:,:,:) = tsn(:,:,:,jp_tem) 
     1186            sn_25h(:,:,:) = tsn(:,:,:,jp_sal) 
     1187            CALL theta2t 
     1188            insitu_t_25h(:,:,:) = insitu_t(:,:,:) 
     1189            sshn_25h(:,:) = sshn (:,:) 
     1190!            hmld_kara_25h(:,:) = hmld_kara(:,:) 
     1191#if defined key_lim3 || defined key_lim2 
     1192            hsnif_25h(:,:) = hsnif(:,:) 
     1193            hicif_25h(:,:) = hicif(:,:) 
     1194            frld_25h(:,:) = frld(:,:) 
     1195#endif  
     1196#if defined key_spm || defined key_MOersem 
     1197            trn_25h(:,:,:,:) = trn (:,:,:,:) 
     1198            trc3d_25h(:,:,:,:) = trc3d(:,:,:,:) 
     1199            trc2d_25h(:,:,:) = trc2d(:,:,:) 
     1200#endif 
     1201            un_25h(:,:,:) = un(:,:,:) 
     1202            vn_25h(:,:,:) = vn(:,:,:) 
     1203            wn_25h(:,:,:) = wn(:,:,:) 
     1204            avt_25h(:,:,:) = avt(:,:,:) 
     1205            avm_25h(:,:,:) = avm(:,:,:) 
     1206# if defined key_zdfgls || defined key_zdftke 
     1207            en_25h(:,:,:) = en(:,:,:) 
     1208#endif 
     1209# if defined key_zdfgls 
     1210            mxln_25h(:,:,:) = mxln(:,:,:) 
     1211#endif 
     1212            cnt_25h = 1 
     1213            IF (lwp)  WRITE(numout,*) 'dia_wri_tide : After 25hr mean write, reset sum to current value and cnt_25h to one for overlapping average',cnt_25h 
     1214 
     1215      ENDIF !  cnt_25h .EQ. 25 .AND.  MOD( kt, i_steps * 24) == 0 .AND. kt .NE. nn_it000 
     1216 
     1217   END SUBROUTINE dia_wri_tide 
     1218   !!====================================================================== 
     1219 
     1220   SUBROUTINE dia_wri_tide_init 
     1221      !!--------------------------------------------------------------------------- 
     1222      !!                  ***  ROUTINE dia_wri_tide_init  *** 
     1223      !!      
     1224      !! ** Purpose: Initialization of 25hour mean variables for detided output   
     1225      !!         
     1226      !! ** Method : Read namelist, allocate and assign initial values 
     1227      !!   History 
     1228      !!   3.4  !  03-13  (E. O'Dea) Routine to initialize dia_wri_tide   
     1229      !!--------------------------------------------------------------------------- 
     1230      !! 
     1231      INTEGER            ::   ierror   ! local integer 
     1232      !! 
     1233      NAMELIST/nam_diatide/ ln_diatide 
     1234      !! 
     1235      !!---------------------------------------------------------------------- 
     1236      ! 
     1237      REWIND ( numnam )              ! Read Namelist nam_tiatide 
     1238      READ   ( numnam, nam_diatide ) 
     1239      ! 
     1240      IF(lwp) THEN                   ! Control print 
     1241         WRITE(numout,*) 
     1242         WRITE(numout,*) 'dia_wri_tide_init : Output 25 hour Mean Diagnostics' 
     1243         WRITE(numout,*) '~~~~~~~~~~~~' 
     1244         WRITE(numout,*) '   Namelist nam_diatide : set 25hour mean outputs ' 
     1245         WRITE(numout,*) '      Switch for 25 hour mean diagnostics (T) or not (F)  ln_diatide  = ', ln_diatide 
     1246      ENDIF 
     1247      IF( .NOT. ln_diatide )   RETURN 
     1248 
     1249      ! ------------------- ! 
     1250      ! 1 - Allocate memory ! 
     1251      ! ------------------- ! 
     1252      ALLOCATE( tn_25h(jpi,jpj,jpk), STAT=ierror ) 
     1253      IF( ierror > 0 ) THEN 
     1254         CALL ctl_stop( 'dia_tide: unable to allocate tn_25h' )   ;   RETURN 
     1255      ENDIF 
     1256      ALLOCATE( sn_25h(jpi,jpj,jpk), STAT=ierror ) 
     1257      IF( ierror > 0 ) THEN 
     1258         CALL ctl_stop( 'dia_tide: unable to allocate sn_25h' )   ;   RETURN 
     1259      ENDIF 
     1260      ALLOCATE( insitu_t_25h(jpi,jpj,jpk), STAT=ierror ) 
     1261      IF( ierror > 0 ) THEN 
     1262         CALL ctl_stop( 'dia_tide: unable to allocate insitu_t_25h' )   ;   RETURN 
     1263      ENDIF 
     1264      ALLOCATE( un_25h(jpi,jpj,jpk), STAT=ierror ) 
     1265      IF( ierror > 0 ) THEN 
     1266         CALL ctl_stop( 'dia_tide: unable to allocate un_25h' )   ;   RETURN 
     1267      ENDIF 
     1268      ALLOCATE( vn_25h(jpi,jpj,jpk), STAT=ierror ) 
     1269      IF( ierror > 0 ) THEN 
     1270         CALL ctl_stop( 'dia_tide: unable to allocate vn_25h' )   ;   RETURN 
     1271      ENDIF 
     1272      ALLOCATE( wn_25h(jpi,jpj,jpk), STAT=ierror ) 
     1273      IF( ierror > 0 ) THEN 
     1274         CALL ctl_stop( 'dia_tide: unable to allocate wn_25h' )   ;   RETURN 
     1275      ENDIF 
     1276      ALLOCATE( avt_25h(jpi,jpj,jpk), STAT=ierror ) 
     1277      IF( ierror > 0 ) THEN 
     1278         CALL ctl_stop( 'dia_tide: unable to allocate avt_25h' )   ;   RETURN 
     1279      ENDIF 
     1280      ALLOCATE( avm_25h(jpi,jpj,jpk), STAT=ierror ) 
     1281      IF( ierror > 0 ) THEN 
     1282         CALL ctl_stop( 'dia_tide: unable to allocate avm_25h' )   ;   RETURN 
     1283      ENDIF 
     1284# if defined key_zdfgls || defined key_zdftke 
     1285      ALLOCATE( en_25h(jpi,jpj,jpk), STAT=ierror ) 
     1286      IF( ierror > 0 ) THEN 
     1287         CALL ctl_stop( 'dia_tide: unable to allocate en_25h' )   ;   RETURN 
     1288      ENDIF 
     1289#endif 
     1290# if defined key_zdfgls  
     1291      ALLOCATE( mxln_25h(jpi,jpj,jpk), STAT=ierror ) 
     1292      IF( ierror > 0 ) THEN 
     1293         CALL ctl_stop( 'dia_tide: unable to allocate mxln_25h' )   ;   RETURN 
     1294      ENDIF 
     1295#endif 
     1296      ALLOCATE( sshn_25h(jpi,jpj), STAT=ierror ) 
     1297      IF( ierror > 0 ) THEN 
     1298         CALL ctl_stop( 'dia_tide: unable to allocate sshn_25h' )   ;   RETURN 
     1299      ENDIF 
     1300      ALLOCATE( hmld_kara_25h(jpi,jpj), STAT=ierror ) 
     1301      IF( ierror > 0 ) THEN 
     1302         CALL ctl_stop( 'dia_tide: unable to allocate hmld_kara_25h' )   ;   RETURN 
     1303      ENDIF 
     1304      ! ------------------------- ! 
     1305      ! 2 - Assign Initial Values ! 
     1306      ! ------------------------- ! 
     1307      cnt_25h = 1  ! sets the first value of sum at timestep 1 (note - should strictly be at timestep zero so before values used where possible)  
     1308      tn_25h(:,:,:) = tsb(:,:,:,jp_tem) 
     1309      sn_25h(:,:,:) = tsb(:,:,:,jp_sal) 
     1310      CALL theta2t 
     1311      insitu_t_25h(:,:,:) = insitu_t(:,:,:) 
     1312      sshn_25h(:,:) = sshb(:,:) 
     1313!         hmld_kara_25h(:,:) = hmld_kara(:,:) 
     1314      un_25h(:,:,:) = ub(:,:,:) 
     1315      vn_25h(:,:,:) = vb(:,:,:) 
     1316      wn_25h(:,:,:) = wn(:,:,:) 
     1317      avt_25h(:,:,:) = avt(:,:,:) 
     1318      avm_25h(:,:,:) = avm(:,:,:) 
     1319# if defined key_zdfgls || defined key_zdftke 
     1320         en_25h(:,:,:) = en(:,:,:) 
     1321#endif 
     1322# if defined key_zdfgls 
     1323         mxln_25h(:,:,:) = mxln(:,:,:) 
     1324#endif 
     1325#if defined key_lim3 || defined key_lim2 
     1326         CALL ctl_stop('STOP', 'dia_wri_tide not setup yet to do tidemean ice') 
     1327#endif  
     1328 
     1329      ! -------------------------- ! 
     1330      ! 3 - Return to dia_wri_tide ! 
     1331      ! -------------------------- ! 
     1332 
     1333 
     1334    END SUBROUTINE dia_wri_tide_init 
     1335 
     1336 
    8001337END MODULE diawri 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

    r7363 r7367  
    77   !!             8.5  !  02-06  (E. Durand, G. Madec)  F90 
    88   !!             9.0  !  06-07  (G. Madec)  add clo_rnf, clo_ups, clo_bat 
     9   !!        NEMO 3.4  !  03-12  (P.G. Fogli) sbc_clo bug fix & mpp reproducibility 
    910   !!---------------------------------------------------------------------- 
    1011 
    … …  
    2021   USE in_out_manager  ! I/O manager 
    2122   USE sbc_oce         ! ocean surface boundary conditions 
    22    USE lib_mpp         ! distributed memory computing library 
    23    USE lbclnk          ! ??? 
     23   USE lib_fortran,    ONLY: glob_sum, DDPDD 
     24   USE lbclnk          ! lateral boundary condition - MPP exchanges 
     25   USE lib_mpp         ! MPP library 
     26   USE timing 
    2427 
    2528   IMPLICIT NONE 
    … …  
    8588         SELECT CASE ( jp_cfg ) 
    8689         !                                           ! ======================= 
     90         CASE ( 1 )                                  ! ORCA_R1 configuration 
     91            !                                        ! ======================= 
     92            ncsnr(1)   = 1    ; ncstt(1)   = 0           ! Caspian Sea 
     93            ncsi1(1)   = 332  ; ncsj1(1)   = 203 
     94            ncsi2(1)   = 344  ; ncsj2(1)   = 235 
     95            ncsir(1,1) = 1    ; ncsjr(1,1) = 1 
     96            !                                         
     97            !                                        ! ======================= 
    8798         CASE ( 2 )                                  !  ORCA_R2 configuration 
    8899            !                                        ! ======================= 
    … …  
    177188      INTEGER, INTENT(in) ::   kt   ! ocean model time step 
    178189      ! 
    179       INTEGER                     ::   ji, jj, jc, jn   ! dummy loop indices 
    180       REAL(wp)                    ::   zze2 
    181       REAL(wp), DIMENSION (jpncs) ::   zfwf  
    182       !!---------------------------------------------------------------------- 
    183       ! 
     190      INTEGER             ::   ji, jj, jc, jn   ! dummy loop indices 
     191      REAL(wp), PARAMETER ::   rsmall = 1.e-20_wp    ! Closed sea correction epsilon 
     192      REAL(wp)            ::   zze2, ztmp, zcorr     !  
     193      COMPLEX(wp)         ::   ctmp  
     194      REAL(wp), DIMENSION(jpncs) ::   zfwf   ! 1D workspace 
     195      !!---------------------------------------------------------------------- 
     196      ! 
     197      IF( nn_timing == 1 )  CALL timing_start('sbc_clo') 
    184198      !                                                   !------------------! 
    185199      IF( kt == nit000 ) THEN                             !  Initialisation  ! 
    … …  
    189203         IF(lwp) WRITE(numout,*)'~~~~~~~' 
    190204 
    191          ! Total surface of ocean 
    192          surf(jpncs+1) = SUM( e1t(:,:) * e2t(:,:) * tmask_i(:,:) ) 
    193  
    194          DO jc = 1, jpncs 
    195             surf(jc) =0.e0 
    196             DO jj = ncsj1(jc), ncsj2(jc) 
    197                DO ji = ncsi1(jc), ncsi2(jc) 
    198                   surf(jc) = surf(jc) + e1t(ji,jj) * e2t(ji,jj) * tmask_i(ji,jj)      ! surface of closed seas 
     205         surf(:) = 0.e0_wp 
     206         ! 
     207         surf(jpncs+1) = glob_sum( e1e2t(:,:) )   ! surface of the global ocean 
     208         ! 
     209         !                                        ! surface of closed seas  
     210         IF( lk_mpp_rep ) THEN                         ! MPP reproductible calculation 
     211            DO jc = 1, jpncs 
     212               ctmp = CMPLX( 0.e0, 0.e0, wp ) 
     213               DO jj = ncsj1(jc), ncsj2(jc) 
     214                  DO ji = ncsi1(jc), ncsi2(jc) 
     215                     ztmp = e1e2t(ji,jj) * tmask_i(ji,jj) 
     216                     CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     217                  END DO  
    199218               END DO  
    200             END DO  
    201          END DO  
    202          IF( lk_mpp )   CALL mpp_sum ( surf, jpncs+1 )       ! mpp: sum over all the global domain 
     219               IF( lk_mpp )   CALL mpp_sum( ctmp ) 
     220               surf(jc) = REAL(ctmp,wp) 
     221            END DO 
     222         ELSE                                          ! Standard calculation            
     223            DO jc = 1, jpncs 
     224               DO jj = ncsj1(jc), ncsj2(jc) 
     225                  DO ji = ncsi1(jc), ncsi2(jc) 
     226                     surf(jc) = surf(jc) + e1e2t(ji,jj) * tmask_i(ji,jj)      ! surface of closed seas 
     227                  END DO  
     228               END DO  
     229            END DO  
     230            IF( lk_mpp )   CALL mpp_sum ( surf, jpncs )       ! mpp: sum over all the global domain 
     231         ENDIF 
    203232 
    204233         IF(lwp) WRITE(numout,*)'     Closed sea surfaces' 
    … …  
    215244      !                                                   !--------------------! 
    216245      !                                                   !  update emp, emps  ! 
    217       zfwf = 0.e0                                         !--------------------! 
    218       DO jc = 1, jpncs 
    219          DO jj = ncsj1(jc), ncsj2(jc) 
    220             DO ji = ncsi1(jc), ncsi2(jc) 
    221                zfwf(jc) = zfwf(jc) + e1t(ji,jj) * e2t(ji,jj) * ( emp(ji,jj)-rnf(ji,jj) ) * tmask_i(ji,jj)  
    222             END DO   
    223          END DO  
    224       END DO 
    225       IF( lk_mpp )   CALL mpp_sum ( zfwf(:) , jpncs )       ! mpp: sum over all the global domain 
     246      zfwf = 0.e0_wp                                      !--------------------! 
     247      IF( lk_mpp_rep ) THEN                         ! MPP reproductible calculation 
     248         DO jc = 1, jpncs 
     249            ctmp = CMPLX( 0.e0, 0.e0, wp ) 
     250            DO jj = ncsj1(jc), ncsj2(jc) 
     251               DO ji = ncsi1(jc), ncsi2(jc) 
     252                  ztmp = e1e2t(ji,jj) * ( emp(ji,jj)-rnf(ji,jj) ) * tmask_i(ji,jj) 
     253                  CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) 
     254               END DO   
     255            END DO  
     256            IF( lk_mpp )   CALL mpp_sum( ctmp ) 
     257            zfwf(jc) = REAL(ctmp,wp) 
     258         END DO 
     259      ELSE                                          ! Standard calculation            
     260         DO jc = 1, jpncs 
     261            DO jj = ncsj1(jc), ncsj2(jc) 
     262               DO ji = ncsi1(jc), ncsi2(jc) 
     263                  zfwf(jc) = zfwf(jc) + e1e2t(ji,jj) * ( emp(ji,jj)-rnf(ji,jj) ) * tmask_i(ji,jj)  
     264               END DO   
     265            END DO  
     266         END DO 
     267         IF( lk_mpp )   CALL mpp_sum ( zfwf(:) , jpncs )       ! mpp: sum over all the global domain 
     268      ENDIF 
    226269 
    227270      IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN      ! Black Sea case for ORCA_R2 configuration 
    228          zze2    = ( zfwf(3) + zfwf(4) ) / 2. 
     271         zze2    = ( zfwf(3) + zfwf(4) ) * 0.5_wp 
    229272         zfwf(3) = zze2 
    230273         zfwf(4) = zze2 
    231274      ENDIF 
    232275 
     276      zcorr = 0._wp 
     277 
    233278      DO jc = 1, jpncs 
    234279         ! 
    235          IF( ncstt(jc) == 0 ) THEN  
    236             ! water/evap excess is shared by all open ocean 
    237             emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 
    238             emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 
    239          ELSEIF( ncstt(jc) == 1 ) THEN  
    240             ! Excess water in open sea, at outflow location, excess evap shared 
    241             IF ( zfwf(jc) <= 0.e0 ) THEN  
    242                 DO jn = 1, ncsnr(jc) 
     280         ! The following if avoids the redistribution of the round off 
     281         IF ( ABS(zfwf(jc) / surf(jpncs+1) ) > rsmall) THEN 
     282            ! 
     283            IF( ncstt(jc) == 0 ) THEN           ! water/evap excess is shared by all open ocean 
     284               emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 
     285               emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 
     286               ! accumulate closed seas correction 
     287               zcorr     = zcorr     + zfwf(jc) / surf(jpncs+1) 
     288               ! 
     289            ELSEIF( ncstt(jc) == 1 ) THEN       ! Excess water in open sea, at outflow location, excess evap shared 
     290               IF ( zfwf(jc) <= 0.e0_wp ) THEN  
     291                   DO jn = 1, ncsnr(jc) 
     292                     ji = mi0(ncsir(jc,jn)) 
     293                     jj = mj0(ncsjr(jc,jn)) ! Location of outflow in open ocean 
     294                     IF (      ji > 1 .AND. ji < jpi   & 
     295                         .AND. jj > 1 .AND. jj < jpj ) THEN  
     296                         emp (ji,jj) = emp (ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) * e1e2t(ji,jj) ) 
     297                         emps(ji,jj) = emps(ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) * e1e2t(ji,jj) ) 
     298                     ENDIF  
     299                   END DO  
     300               ELSE  
     301                   emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 
     302                   emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 
     303                   ! accumulate closed seas correction 
     304                   zcorr     = zcorr     + zfwf(jc) / surf(jpncs+1) 
     305               ENDIF 
     306            ELSEIF( ncstt(jc) == 2 ) THEN       ! Excess e-p-r (either sign) goes to open ocean, at outflow location 
     307               DO jn = 1, ncsnr(jc) 
    243308                  ji = mi0(ncsir(jc,jn)) 
    244309                  jj = mj0(ncsjr(jc,jn)) ! Location of outflow in open ocean 
    245                   IF (      ji > 1 .AND. ji < jpi   & 
    246                       .AND. jj > 1 .AND. jj < jpj ) THEN  
    247                       emp (ji,jj) = emp (ji,jj) + zfwf(jc) /   & 
    248                          (FLOAT(ncsnr(jc)) * e1t(ji,jj) * e2t(ji,jj)) 
    249                       emps(ji,jj) = emps(ji,jj) + zfwf(jc) /   & 
    250                           (FLOAT(ncsnr(jc)) * e1t(ji,jj) * e2t(ji,jj)) 
    251                   END IF  
    252                 END DO  
    253             ELSE  
    254                 emp (:,:) = emp (:,:) + zfwf(jc) / surf(jpncs+1) 
    255                 emps(:,:) = emps(:,:) + zfwf(jc) / surf(jpncs+1) 
    256             ENDIF 
    257          ELSEIF( ncstt(jc) == 2 ) THEN  
    258             ! Excess e-p+r (either sign) goes to open ocean, at outflow location 
    259             IF(      ji > 1 .AND. ji < jpi    & 
    260                .AND. jj > 1 .AND. jj < jpj ) THEN  
    261                 DO jn = 1, ncsnr(jc) 
    262                   ji = mi0(ncsir(jc,jn)) 
    263                   jj = mj0(ncsjr(jc,jn)) ! Location of outflow in open ocean 
    264                   emp (ji,jj) = emp (ji,jj) + zfwf(jc)   & 
    265                       / (FLOAT(ncsnr(jc)) *  e1t(ji,jj) * e2t(ji,jj) ) 
    266                   emps(ji,jj) = emps(ji,jj) + zfwf(jc)   & 
    267                       / (FLOAT(ncsnr(jc)) *  e1t(ji,jj) * e2t(ji,jj) ) 
    268                 END DO  
     310                  IF(      ji > 1 .AND. ji < jpi    & 
     311                     .AND. jj > 1 .AND. jj < jpj ) THEN  
     312                     emp (ji,jj) = emp (ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) *  e1e2t(ji,jj) ) 
     313                     emps(ji,jj) = emps(ji,jj) + zfwf(jc) / ( REAL(ncsnr(jc)) *  e1e2t(ji,jj) ) 
     314                  ENDIF  
     315               END DO  
    269316            ENDIF  
    270          ENDIF  
    271          ! 
    272          DO jj = ncsj1(jc), ncsj2(jc) 
    273             DO ji = ncsi1(jc), ncsi2(jc) 
    274                emp (ji,jj) = emp (ji,jj) - zfwf(jc) / surf(jc) 
    275                emps(ji,jj) = emps(ji,jj) - zfwf(jc) / surf(jc) 
    276             END DO   
    277          END DO  
    278          ! 
     317            ! 
     318            DO jj = ncsj1(jc), ncsj2(jc) 
     319               DO ji = ncsi1(jc), ncsi2(jc) 
     320                  emp (ji,jj) = emp (ji,jj) - zfwf(jc) / surf(jc) 
     321                  emps(ji,jj) = emps(ji,jj) - zfwf(jc) / surf(jc) 
     322               END DO   
     323            END DO  
     324            ! 
     325         END IF 
    279326      END DO  
    280       ! 
    281       CALL lbc_lnk( emp , 'T', 1. ) 
    282       CALL lbc_lnk( emps, 'T', 1. ) 
     327 
     328      IF ( ABS(zcorr) > rsmall ) THEN      ! remove the global correction from the closed seas 
     329         DO jc = 1, jpncs                  ! only if it is large enough 
     330            DO jj = ncsj1(jc), ncsj2(jc) 
     331               DO ji = ncsi1(jc), ncsi2(jc) 
     332                  emp (ji,jj) = emp (ji,jj) - zcorr 
     333                  emps(ji,jj) = emps(ji,jj) - zcorr 
     334               END DO   
     335             END DO  
     336          END DO 
     337      ENDIF 
     338      ! 
     339      emp (:,:) = emp (:,:) * tmask(:,:,1) 
     340      emps(:,:) = emps(:,:) * tmask(:,:,1) 
     341      ! 
     342      CALL lbc_lnk( emp , 'T', 1._wp ) 
     343      CALL lbc_lnk( emps, 'T', 1._wp ) 
     344      ! 
     345      IF( nn_timing == 1 )  CALL timing_stop('sbc_clo') 
    283346      ! 
    284347   END SUBROUTINE sbc_clo 
    285     
    286     
     348 
     349 
    287350   SUBROUTINE clo_rnf( p_rnfmsk ) 
    288351      !!--------------------------------------------------------------------- 
    … …  
    308371               ii = mi0( ncsir(jc,jn) ) 
    309372               ij = mj0( ncsjr(jc,jn) ) 
    310                p_rnfmsk(ii,ij) = MAX( p_rnfmsk(ii,ij), 1.0 ) 
     373               p_rnfmsk(ii,ij) = MAX( p_rnfmsk(ii,ij), 1.0_wp ) 
    311374            END DO  
    312375         ENDIF  
    … …  
    336399         DO jj = ncsj1(jc), ncsj2(jc) 
    337400            DO ji = ncsi1(jc), ncsi2(jc) 
    338                p_upsmsk(ji,jj) = 0.5            ! mixed upstream/centered scheme over closed seas 
     401               p_upsmsk(ji,jj) = 0.5_wp         ! mixed upstream/centered scheme over closed seas 
    339402            END DO  
    340403         END DO  
    … …  
    374437   !!====================================================================== 
    375438END MODULE closea 
     439 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r7363 r7367  
    116116 
    117117      ! number of seconds since the beginning of current year/month/week/day at the middle of the time-step 
    118       nsec_year  = nday_year * nsecd - ndt05   ! 1 time step before the middle of the first time step 
    119       nsec_month = nday      * nsecd - ndt05   ! because day will be called at the beginning of step 
    120       nsec_week  = idweek    * nsecd - ndt05 
    121       nsec_day   =             nsecd - ndt05 
     118      nsec_year  = nday_year * nsecd - ndt   ! 1 time step before the middle of the first time step 
     119      nsec_month = nday      * nsecd - ndt   ! because day will be called at the beginning of step 
     120      nsec_week  = idweek    * nsecd - ndt 
     121      nsec_day   =             nsecd - ndt 
    122122 
    123123      ! control print 
    … …  
    219219      IF( ABS(adatrj  - REAL(NINT(adatrj ),wp)) < zprec )   adatrj  = REAL(NINT(adatrj ),wp)   ! avoid truncation error 
    220220       
    221       IF( nsec_day > nsecd ) THEN                       ! New day 
     221      IF( nsec_day >= nsecd ) THEN                       ! New day 
    222222         ! 
    223223         nday      = nday + 1 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r7363 r7367  
    5252   REAL(wp), PUBLIC ::   rdtmax          !: maximum time step on tracers 
    5353   REAL(wp), PUBLIC ::   rdth            !: depth variation of tracer step 
    54    INTEGER , PUBLIC ::   nclosea         !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 
    5554 
    5655   !                                                  !!! associated variables 
    … …  
    125124   LOGICAL, PUBLIC ::   ln_zps     =  .FALSE.   !: z-coordinate - partial step 
    126125   LOGICAL, PUBLIC ::   ln_sco     =  .FALSE.   !: s-coordinate or hybrid z-s coordinate 
     126   LOGICAL, PUBLIC ::   ln_read_zenv     =  .FALSE.   !: Whether to read zenv or calculate it 
    127127 
    128128   !! All coordinates 
    … …  
    173173   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   scosrf, scobot   !: ocean surface and bottom topographies  
    174174   !                                        !  (if deviating from coordinate surfaces in HYBRID) 
     175   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rx1              !: maximum grid stiffness ratio 
    175176   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hifv  , hiff     !: interface depth between stretching at  V--F 
    176177   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hift  , hifu     !: and quasi-uniform spacing              T--U  points (m) 
     178   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zenv    !:       Envelope Batymetry, calcualted or read in  
    177179 
    178180   !!---------------------------------------------------------------------- 
    … …  
    295297         &      scosrf(jpi,jpj) , scobot(jpi,jpj) ,     & 
    296298         &      hifv  (jpi,jpj) , hiff  (jpi,jpj) ,     & 
    297          &      hift  (jpi,jpj) , hifu  (jpi,jpj) , STAT=ierr(8) ) 
     299         &      hift  (jpi,jpj) , hifu  (jpi,jpj) , rx1(jpi,jpj), STAT=ierr(8) ) 
    298300 
    299301      ALLOCATE( mbathy(jpi,jpj) , bathy(jpi,jpj) ,                     & 
    300302         &     tmask_i(jpi,jpj) , bmask(jpi,jpj) ,                     & 
    301          &     mbkt   (jpi,jpj) , mbku (jpi,jpj) , mbkv(jpi,jpj) , STAT=ierr(9) ) 
     303         &     mbkt   (jpi,jpj) , mbku (jpi,jpj) , mbkv(jpi,jpj) , zenv(jpi,jpj), STAT=ierr(9) ) 
    302304 
    303305      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk),     &  

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r7363 r7367  
    3636   USE dyncor_c1d      ! Coriolis term (c1d case)         (cor_c1d routine) 
    3737   USE timing          ! Timing 
     38   USE lbclnk 
    3839 
    3940   IMPLICIT NONE 
    … …  
    8485                             CALL dom_zgr      ! Vertical mesh and bathymetry 
    8586                             CALL dom_msk      ! Masks 
     87      IF( ln_sco )           CALL dom_stiff    ! Maximum stiffness ratio/hydrostatic consistency       
    8688      IF( lk_vvl         )   CALL dom_vvl      ! Vertical variable mesh 
    8789      ! 
    … …  
    123125      !!---------------------------------------------------------------------- 
    124126      USE ioipsl 
     127      NAMELIST/namrun/ ln_NOOS   
    125128      NAMELIST/namrun/ nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl,   & 
     129         &             nn_stocklist,                                                               & 
    126130         &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   & 
    127          &             nn_write, ln_dimgnnn, ln_mskland  , ln_clobber   , nn_chunksz 
     131         &             nn_write, ln_dimgnnn, ln_mskland  , ln_clobber   , nn_chunksz,              & 
     132         &             ln_diafoam, nn_diafoam, ln_depwri  
    128133      NAMELIST/namdom/ nn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh    , rn_hmin,   & 
    129134         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,            & 
    130135         &             rn_rdtmax, rn_rdth     , nn_baro     , nn_closea 
    131136      NAMELIST/namcla/ nn_cla 
     137      NAMELIST/namrun/ ln_rstdate 
    132138#if defined key_netcdf4 
    133139      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip 
    134140#endif 
    135       !!---------------------------------------------------------------------- 
    136  
     141      NAMELIST/namrun/ ln_diatide 
     142      !!---------------------------------------------------------------------- 
     143      NAMELIST/namrun/ ln_diatmb 
     144 
     145 
     146      NAMELIST/namrun/ cn_rst_dir ! moved here to allow merge with CO5 branches (ln_NOOS)                                                                  
    137147      REWIND( numnam )              ! Namelist namrun : parameters of the run 
    138148      READ  ( numnam, namrun ) 
    … …  
    152162         WRITE(numout,*) '      leap year calendar (0/1)        nn_leapy   = ', nn_leapy 
    153163         WRITE(numout,*) '      initial state output            nn_istate  = ', nn_istate 
    154          WRITE(numout,*) '      frequency of restart file       nn_stock   = ', nn_stock 
     164         IF ( ALL( nn_stocklist == 0 ) ) THEN   
     165            WRITE(numout,*) '   frequency of restart file       nn_stock   = ', nn_stock 
     166         ELSE   
     167            WRITE(numout,*) '   list of restart times           nn_stocklist = ', nn_stocklist(1:10)   
     168         ENDIF   
    155169         WRITE(numout,*) '      frequency of output file        nn_write   = ', nn_write 
    156170         WRITE(numout,*) '      multi file dimgout              ln_dimgnnn = ', ln_dimgnnn 
     171         WRITE(numout,*) '      use date in restart name        ln_rstdate = ', ln_rstdate  
    157172         WRITE(numout,*) '      mask land points                ln_mskland = ', ln_mskland 
     173         WRITE(numout,*) '      NOOS transect diagnostics       ln_NOOS    = ', ln_NOOS 
    158174         WRITE(numout,*) '      overwrite an existing file      ln_clobber = ', ln_clobber 
     175         WRITE(numout,*) '      restart directory               cn_rst_dir = ', cn_rst_dir  
    159176         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz = ', nn_chunksz 
     177         WRITE(numout,*) '      Met Office FOAM diagnostics     ln_diafoam = ', ln_diafoam   
     178         WRITE(numout,*) '      FOAM diagnostic choices         nn_diafoam = ', nn_diafoam   
     179         WRITE(numout,*) '      depths file output logical      ln_depwri  = ', ln_depwri  
    160180      ENDIF 
    161181 
    … …  
    169189      ninist = nn_istate 
    170190      nstock = nn_stock 
     191      nstock_list = nn_stocklist 
    171192      nwrite = nn_write 
    172193 
    … …  
    238259      rdtmax    = rn_rdtmin 
    239260      rdth      = rn_rdth 
    240       nclosea   = nn_closea 
    241261 
    242262      REWIND( numnam )              ! Namelist cross land advection 
    … …  
    274294 
    275295 
     296   !!====================================================================== 
    276297   SUBROUTINE dom_ctl 
    277298      !!---------------------------------------------------------------------- 
    … …  
    323344   END SUBROUTINE dom_ctl 
    324345 
     346   SUBROUTINE dom_stiff 
     347      !!---------------------------------------------------------------------- 
     348      !!                  ***  ROUTINE dom_stiff  *** 
     349      !!                      
     350      !! ** Purpose :   Diagnose maximum grid stiffness/hydrostatic consistency 
     351      !! 
     352      !! ** Method  :   Compute Haney (1991) hydrostatic condition ratio 
     353      !!                Save the maximum in the vertical direction 
     354      !!                (this number is only relevant in s-coordinates) 
     355      !! 
     356      !!                Haney, R. L., 1991: On the pressure gradient force 
     357      !!                over steep topography in sigma coordinate ocean models.  
     358      !!                J. Phys. Oceanogr., 21, 610???619. 
     359      !!---------------------------------------------------------------------- 
     360      INTEGER  ::   ji, jj, jk  
     361      REAL(wp) ::   zrxmax 
     362      REAL(wp), DIMENSION(4) :: zr1 
     363      !!---------------------------------------------------------------------- 
     364      rx1(:,:) = 0.e0 
     365      zrxmax   = 0.e0 
     366      zr1(:)   = 0.e0 
     367       
     368      DO ji = 2, jpim1 
     369         DO jj = 2, jpjm1 
     370            DO jk = 1, jpkm1 
     371               zr1(1) = umask(ji-1,jj  ,jk) *abs( (gdepw(ji  ,jj  ,jk  )-gdepw(ji-1,jj  ,jk  )  &  
     372                    &                         +gdepw(ji  ,jj  ,jk+1)-gdepw(ji-1,jj  ,jk+1)) & 
     373                    &                        /(gdepw(ji  ,jj  ,jk  )+gdepw(ji-1,jj  ,jk  )  & 
     374                    &                         -gdepw(ji  ,jj  ,jk+1)-gdepw(ji-1,jj  ,jk+1) + rsmall) ) 
     375               zr1(2) = umask(ji  ,jj  ,jk) *abs( (gdepw(ji+1,jj  ,jk  )-gdepw(ji  ,jj  ,jk  )  & 
     376                    &                         +gdepw(ji+1,jj  ,jk+1)-gdepw(ji  ,jj  ,jk+1)) & 
     377                    &                        /(gdepw(ji+1,jj  ,jk  )+gdepw(ji  ,jj  ,jk  )  & 
     378                    &                         -gdepw(ji+1,jj  ,jk+1)-gdepw(ji  ,jj  ,jk+1) + rsmall) ) 
     379               zr1(3) = vmask(ji  ,jj  ,jk) *abs( (gdepw(ji  ,jj+1,jk  )-gdepw(ji  ,jj  ,jk  )  & 
     380                    &                         +gdepw(ji  ,jj+1,jk+1)-gdepw(ji  ,jj  ,jk+1)) & 
     381                    &                        /(gdepw(ji  ,jj+1,jk  )+gdepw(ji  ,jj  ,jk  )  & 
     382                    &                         -gdepw(ji  ,jj+1,jk+1)-gdepw(ji  ,jj  ,jk+1) + rsmall) ) 
     383               zr1(4) = vmask(ji  ,jj-1,jk) *abs( (gdepw(ji  ,jj  ,jk  )-gdepw(ji  ,jj-1,jk  )  & 
     384                    &                         +gdepw(ji  ,jj  ,jk+1)-gdepw(ji  ,jj-1,jk+1)) & 
     385                    &                        /(gdepw(ji  ,jj  ,jk  )+gdepw(ji  ,jj-1,jk  )  & 
     386                    &                         -gdepw(ji,  jj  ,jk+1)-gdepw(ji  ,jj-1,jk+1) + rsmall) ) 
     387               zrxmax = MAXVAL(zr1(1:4)) 
     388               rx1(ji,jj) = MAX(rx1(ji,jj), zrxmax) 
     389            END DO 
     390         END DO 
     391      END DO 
     392 
     393      CALL lbc_lnk( rx1, 'T', 1. ) 
     394 
     395      zrxmax = MAXVAL(rx1) 
     396 
     397      IF( lk_mpp )   CALL mpp_max( zrxmax ) ! max over the global domain 
     398 
     399      IF(lwp) THEN 
     400         WRITE(numout,*) 
     401         WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax 
     402         WRITE(numout,*) '~~~~~~~~~' 
     403      ENDIF 
     404 
     405   END SUBROUTINE dom_stiff 
     406 
    325407   !!====================================================================== 
    326408END MODULE domain 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r7363 r7367  
    172172             
    173173      IF( ln_sco ) THEN                                         ! s-coordinate 
    174          CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt )         !    ! depth 
    175          CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu )  
     174         CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt ) 
     175         CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu ) 
    176176         CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv ) 
    177177         CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf ) 
    … …  
    187187         CALL iom_rstput( 0, 0, inum4, 'e3v', e3v ) 
    188188         CALL iom_rstput( 0, 0, inum4, 'e3w', e3w ) 
    189          ! 
    190          CALL iom_rstput( 0, 0, inum4, 'gdept_0' , gdept_0 )    !    ! stretched system 
    191          CALL iom_rstput( 0, 0, inum4, 'gdepw_0' , gdepw_0 ) 
     189         CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 )             !    ! Max. grid stiffness ratio 
     190         ! 
     191         CALL iom_rstput( 0, 0, inum4, 'gdept' , gdept )    !    ! stretched system 
     192         CALL iom_rstput( 0, 0, inum4, 'gdepw' , gdepw ) 
    192193      ENDIF 
    193194       

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r7363 r7367  
    1515   !!            3.2  ! 2009-07  (R. Benshila) Suppression of rigid-lid option 
    1616   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
     17   !!            3.4  ! 2012-08  (J. Siddorn) added Siddorn adn Furner stretching functio 
    1718   !!---------------------------------------------------------------------- 
    1819 
    … …  
    2829   !!       zgr_sco      : s-coordinate 
    2930   !!       fssig        : sigma coordinate non-dimensional function 
     31   !!       fgamma       : Siddorn and Furner stretching function 
    3032   !!       dfssig       : derivative of the sigma coordinate function    !!gm  (currently missing!) 
    3133   !!--------------------------------------------------------------------- 
    … …  
    4749 
    4850   !                                       !!* Namelist namzgr_sco * 
     51   LOGICAL  ::   ln_s_sh94   = .false.      ! use hybrid s-sig Song and Haidvogel 1994 stretching function fssig1 (ln_sco=T) 
     52   LOGICAL  ::   ln_s_sf12   = .true.       ! use hybrid s-z-sig Siddorn and Furner 2012 stretching function fgamma (ln_sco=T) 
     53   LOGICAL  ::   ln_sigcrit  = .false.      ! use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch  
     54   ! 
    4955   REAL(wp) ::   rn_sbot_min =  300._wp     ! minimum depth of s-bottom surface (>0) (m) 
    5056   REAL(wp) ::   rn_sbot_max = 5250._wp     ! maximum depth of s-bottom surface (= ocean depth) (>0) (m) 
     57   REAL(wp) ::   rn_rmax     =    0.15_wp   ! maximum cut-off r-value allowed (0<rn_rmax<1) 
     58   REAL(wp) ::   rn_hc       =  150._wp     ! Critical depth for transition from sigma to stretched coordinates 
     59   ! Song and Haidvogel 1994 stretching parameters 
    5160   REAL(wp) ::   rn_theta    =    6.00_wp   ! surface control parameter (0<=rn_theta<=20) 
    5261   REAL(wp) ::   rn_thetb    =    0.75_wp   ! bottom control parameter  (0<=rn_thetb<= 1) 
    53    REAL(wp) ::   rn_rmax     =    0.15_wp   ! maximum cut-off r-value allowed (0<rn_rmax<1) 
    54    LOGICAL  ::   ln_s_sigma  = .false.      ! use hybrid s-sigma -coordinate & stretching function fssig1 (ln_sco=T) 
    55    REAL(wp) ::   rn_bb       =    0.80_wp   ! stretching parameter for song and haidvogel stretching 
     62   REAL(wp) ::   rn_bb       =    0.80_wp   ! stretching parameter  
    5663   !                                        ! ( rn_bb=0; top only, rn_bb =1; top and bottom) 
    57    REAL(wp) ::   rn_hc       =  150._wp     ! Critical depth for s-sigma coordinates 
     64   ! Siddorn and Furner stretching parameters 
     65   REAL(wp) ::   rn_alpha    =    4.4_wp    ! control parameter ( > 1 stretch towards surface, < 1 towards seabed) 
     66   REAL(wp) ::   rn_efold    =    0.0_wp    !  efold length scale for transition to stretched coord 
     67   REAL(wp) ::   rn_zs       =    1.0_wp    !  depth of surface grid box 
     68                           !  bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b 
     69   REAL(wp) ::   rn_zb_a     =    0.024_wp  !  bathymetry scaling factor for calculating Zb 
     70   REAL(wp) ::   rn_zb_b     =   -0.2_wp    !  offset for calculating Zb 
    5871 
    5972  !! * Substitutions 
    … …  
    8699      INTEGER ::   ioptio = 0   ! temporary integer 
    87100      ! 
    88       NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco 
     101      NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_read_zenv 
    89102      !!---------------------------------------------------------------------- 
    90103      ! 
    … …  
    102115         WRITE(numout,*) '             z-coordinate - partial steps   ln_zps = ', ln_zps 
    103116         WRITE(numout,*) '             s- or hybrid z-s-coordinate    ln_sco = ', ln_sco 
     117         WRITE(numout,*) '             Read Zenv from Bathy T/F ln_read_zenv = ', ln_read_zenv 
    104118      ENDIF 
    105119 
    … …  
    243257         END DO 
    244258      ELSE                                ! Madec & Imbard 1996 function 
     259# if key_levels==1  
     260         !Hard wire a deep and shallow level  
     261         !NOTE this configuration is for use with NEMOVAR,   
     262         !it is not set-up for NEMO  
     263         CALL ctl_warn("Single level model, depth of first layer set to 1cm."//&  
     264             &  "\nThis configuration is designed to be used with NEMOVAR only")  
     265         gdepw_0(1)=0  
     266         gdept_0(1)=0.01  
     267         gdepw_0(2)=7000  
     268         gdept_0(2)=14000  
     269         e3w_0(:)=7000  
     270         e3t_0(1)=6999.99  
     271         e3t_0(2)=7000  
     272# else  
    245273         IF( .NOT. ldbletanh ) THEN 
    246274            DO jk = 1, jpk 
    … …  
    267295            END DO 
    268296         ENDIF 
     297# endif 
    269298         gdepw_0(1) = 0._wp                    ! force first w-level to be exactly at zero 
    270299      ENDIF 
    … …  
    422451            CALL iom_close( inum ) 
    423452            mbathy(:,:) = INT( bathy(:,:) ) 
    424             !                                                ! ===================== 
     453            ! 
    425454            IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN    ! ORCA R2 configuration 
    426                !                                             ! ===================== 
     455               ! 
    427456               IF( nn_cla == 0 ) THEN 
    428457                  ii0 = 140   ;   ii1 = 140                  ! Gibraltar Strait open  
    … …  
    453482            CALL iom_open ( 'bathy_meter.nc', inum )  
    454483            CALL iom_get  ( inum, jpdom_data, 'Bathymetry', bathy ) 
     484            IF ( ln_read_zenv ) THEN                  ! Whether we should read zenv or not 
     485                CALL iom_get  ( inum, jpdom_data, 'zenv', zenv ) 
     486            ENDIF 
    455487            CALL iom_close( inum ) 
    456             !                                                ! ===================== 
     488            !                                                 
    457489            IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN    ! ORCA R2 configuration 
    458                !                                             ! ===================== 
     490               ! 
    459491              IF( nn_cla == 0 ) THEN 
    460492                 ii0 = 140   ;   ii1 = 140                   ! Gibraltar Strait open  
    … …  
    489521      ENDIF 
    490522      ! 
    491       !                                               ! =========================== ! 
    492       IF( nclosea == 0 ) THEN                         !   NO closed seas or lakes   ! 
    493          DO jl = 1, jpncs                             ! =========================== ! 
    494             DO jj = ncsj1(jl), ncsj2(jl) 
    495                DO ji = ncsi1(jl), ncsi2(jl) 
    496                   mbathy(ji,jj) = 0                   ! suppress closed seas and lakes from bathymetry 
    497                   bathy (ji,jj) = 0._wp                
    498                END DO 
    499             END DO 
    500          END DO 
    501       ENDIF 
    502       ! 
    503       !                                               ! =========================== ! 
    504       !                                               !     set a minimum depth     ! 
    505       !                                               ! =========================== ! 
    506       IF ( .not. ln_sco ) THEN 
     523      IF( nn_closea == 0 )   CALL clo_bat( bathy, mbathy )    !==  NO closed seas or lakes  ==! 
     524      !                        
     525      IF ( .not. ln_sco ) THEN                                !==  set a minimum depth  ==! 
    507526         IF( rn_hmin < 0._wp ) THEN    ;   ik = - INT( rn_hmin )                                      ! from a nb of level 
    508527         ELSE                          ;   ik = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
    … …  
    10471066   END SUBROUTINE zgr_zps 
    10481067 
    1049  
    1050    FUNCTION fssig( pk ) RESULT( pf ) 
    1051       !!---------------------------------------------------------------------- 
    1052       !!                 ***  ROUTINE eos_init  *** 
    1053       !!        
    1054       !! ** Purpose :   provide the analytical function in s-coordinate 
    1055       !!           
    1056       !! ** Method  :   the function provide the non-dimensional position of 
    1057       !!                T and W (i.e. between 0 and 1) 
    1058       !!                T-points at integer values (between 1 and jpk) 
    1059       !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
    1060       !!---------------------------------------------------------------------- 
    1061       REAL(wp), INTENT(in) ::   pk   ! continuous "k" coordinate 
    1062       REAL(wp)             ::   pf   ! sigma value 
    1063       !!---------------------------------------------------------------------- 
    1064       ! 
    1065       pf =   (   TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb )  )   & 
    1066          &     - TANH( rn_thetb * rn_theta                                )  )   & 
    1067          & * (   COSH( rn_theta                           )                      & 
    1068          &     + COSH( rn_theta * ( 2._wp * rn_thetb - 1._wp ) )  )              & 
    1069          & / ( 2._wp * SINH( rn_theta ) ) 
    1070       ! 
    1071    END FUNCTION fssig 
    1072  
    1073  
    1074    FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) 
    1075       !!---------------------------------------------------------------------- 
    1076       !!                 ***  ROUTINE eos_init  *** 
    1077       !! 
    1078       !! ** Purpose :   provide the Song and Haidvogel version of the analytical function in s-coordinate 
    1079       !! 
    1080       !! ** Method  :   the function provides the non-dimensional position of 
    1081       !!                T and W (i.e. between 0 and 1) 
    1082       !!                T-points at integer values (between 1 and jpk) 
    1083       !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
    1084       !!---------------------------------------------------------------------- 
    1085       REAL(wp), INTENT(in) ::   pk1   ! continuous "k" coordinate 
    1086       REAL(wp), INTENT(in) ::   pbb   ! Stretching coefficient 
    1087       REAL(wp)             ::   pf1   ! sigma value 
    1088       !!---------------------------------------------------------------------- 
    1089       ! 
    1090       IF ( rn_theta == 0 ) then      ! uniform sigma 
    1091          pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 
    1092       ELSE                        ! stretched sigma 
    1093          pf1 =   ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta )              & 
    1094             &  + pbb * (  (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta )  )  & 
    1095             &        / ( 2._wp * TANH( 0.5_wp * rn_theta ) )  ) 
    1096       ENDIF 
    1097       ! 
    1098    END FUNCTION fssig1 
    1099  
    1100  
    11011068   SUBROUTINE zgr_sco 
    11021069      !!---------------------------------------------------------------------- 
    … …  
    11231090      !!            esigt(k) = fsdsig(k    ) 
    11241091      !!            esigw(k) = fsdsig(k-0.5) 
    1125       !!      This routine is given as an example, it must be modified 
    1126       !!      following the user s desiderata. nevertheless, the output as 
     1092      !!      Three options for stretching are give, and they can be modified 
     1093      !!      following the users requirements. Nevertheless, the output as 
    11271094      !!      well as the way to compute the model levels and scale factors 
    1128       !!      must be respected in order to insure second order a!!uracy 
     1095      !!      must be respected in order to insure second order accuracy 
    11291096      !!      schemes. 
    11301097      !! 
    1131       !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. 
     1098      !!      The three methods for stretching available are: 
     1099      !!  
     1100      !!           s_sh94 (Song and Haidvogel 1994) 
     1101      !!                a sinh/tanh function that allows sigma and stretched sigma 
     1102      !! 
     1103      !!           s_sf12 (Siddorn and Furner 2012?) 
     1104      !!                allows the maintenance of fixed surface and or 
     1105      !!                bottom cell resolutions (cf. geopotential coordinates)  
     1106      !!                within an analytically derived stretched S-coordinate framework. 
     1107      !!  
     1108      !!          s_tanh  (Madec et al 1996) 
     1109      !!                a cosh/tanh function that gives stretched coordinates         
     1110      !! 
    11321111      !!---------------------------------------------------------------------- 
    11331112      ! 
    11341113      INTEGER  ::   ji, jj, jk, jl           ! dummy loop argument 
    11351114      INTEGER  ::   iip1, ijp1, iim1, ijm1   ! temporary integers 
    1136       REAL(wp) ::   zcoeft, zcoefw, zrmax, ztaper   ! temporary scalars 
    1137       ! 
    1138       REAL(wp), POINTER, DIMENSION(:,:  ) :: zenv, ztmp, zmsk, zri, zrj, zhbat 
     1115      REAL(wp) ::   zrmax, ztaper   ! temporary scalars 
     1116      ! 
     1117      REAL(wp), POINTER, DIMENSION(:,:  ) :: ztmp, zmsk, zri, zrj, zhbat 
    11391118      REAL(wp), POINTER, DIMENSION(:,:,:) :: gsigw3, gsigt3, gsi3w3 
    11401119      REAL(wp), POINTER, DIMENSION(:,:,:) :: esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3            
    11411120 
    1142       NAMELIST/namzgr_sco/ rn_sbot_max, rn_sbot_min, rn_theta, rn_thetb, rn_rmax, ln_s_sigma, rn_bb, rn_hc 
    1143       !!---------------------------------------------------------------------- 
     1121      NAMELIST/namzgr_sco/ln_s_sh94, ln_s_sf12, ln_sigcrit, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, & 
     1122                           rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b 
     1123     !!---------------------------------------------------------------------- 
    11441124      ! 
    11451125      IF( nn_timing == 1 )  CALL timing_start('zgr_sco') 
    11461126      ! 
    1147       CALL wrk_alloc( jpi, jpj,      zenv, ztmp, zmsk, zri, zrj, zhbat                           ) 
     1127      CALL wrk_alloc( jpi, jpj,      ztmp, zmsk, zri, zrj, zhbat                           ) 
    11481128      CALL wrk_alloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
    11491129      CALL wrk_alloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
    … …  
    11571137         WRITE(numout,*) '~~~~~~~~~~~' 
    11581138         WRITE(numout,*) '   Namelist namzgr_sco' 
    1159          WRITE(numout,*) '      sigma-stretching coeffs ' 
    1160          WRITE(numout,*) '      maximum depth of s-bottom surface (>0)       rn_sbot_max   = ' ,rn_sbot_max 
    1161          WRITE(numout,*) '      minimum depth of s-bottom surface (>0)       rn_sbot_min   = ' ,rn_sbot_min 
    1162          WRITE(numout,*) '      surface control parameter (0<=rn_theta<=20)  rn_theta      = ', rn_theta 
    1163          WRITE(numout,*) '      bottom  control parameter (0<=rn_thetb<= 1)  rn_thetb      = ', rn_thetb 
    1164          WRITE(numout,*) '      maximum cut-off r-value allowed              rn_rmax       = ', rn_rmax 
    1165          WRITE(numout,*) '      Hybrid s-sigma-coordinate                    ln_s_sigma    = ', ln_s_sigma 
    1166          WRITE(numout,*) '      stretching parameter (song and haidvogel)    rn_bb         = ', rn_bb 
    1167          WRITE(numout,*) '      Critical depth                               rn_hc         = ', rn_hc 
    1168       ENDIF 
    1169  
    1170       gsigw3  = 0._wp   ;   gsigt3  = 0._wp   ;   gsi3w3  = 0._wp 
    1171       esigt3  = 0._wp   ;   esigw3  = 0._wp  
    1172       esigtu3 = 0._wp   ;   esigtv3 = 0._wp   ;   esigtf3 = 0._wp 
    1173       esigwu3 = 0._wp   ;   esigwv3 = 0._wp 
     1139         WRITE(numout,*) '     stretching coeffs ' 
     1140         WRITE(numout,*) '        maximum depth of s-bottom surface (>0)       rn_sbot_max   = ',rn_sbot_max 
     1141         WRITE(numout,*) '        minimum depth of s-bottom surface (>0)       rn_sbot_min   = ',rn_sbot_min 
     1142         WRITE(numout,*) '        Critical depth                               rn_hc         = ',rn_hc 
     1143         WRITE(numout,*) '        maximum cut-off r-value allowed              rn_rmax       = ',rn_rmax 
     1144         WRITE(numout,*) '     Song and Haidvogel 1994 stretching              ln_s_sh94     = ',ln_s_sh94 
     1145         WRITE(numout,*) '        Song and Haidvogel 1994 stretching coefficients' 
     1146         WRITE(numout,*) '        surface control parameter (0<=rn_theta<=20)  rn_theta      = ',rn_theta 
     1147         WRITE(numout,*) '        bottom  control parameter (0<=rn_thetb<= 1)  rn_thetb      = ',rn_thetb 
     1148         WRITE(numout,*) '        stretching parameter (song and haidvogel)    rn_bb         = ',rn_bb 
     1149         WRITE(numout,*) '     Siddorn and Furner 2012 stretching              ln_s_sf12     = ',ln_s_sf12 
     1150         WRITE(numout,*) '        Siddorn and Furner 2012 stretching coefficients' 
     1151         WRITE(numout,*) '        stretchin parameter ( >1 surface; <1 bottom) rn_alpha      = ',rn_alpha 
     1152         WRITE(numout,*) '        e-fold length scale for transition region    rn_efold      = ',rn_efold 
     1153         WRITE(numout,*) '        Surface cell depth (Zs) (m)                  rn_zs         = ',rn_zs 
     1154         WRITE(numout,*) '        Bathymetry multiplier for Zb                 rn_zb_a       = ',rn_zb_a 
     1155         WRITE(numout,*) '        Offset for Zb                                rn_zb_b       = ',rn_zb_b 
     1156         WRITE(numout,*) '        Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b' 
     1157      ENDIF 
    11741158 
    11751159      hift(:,:) = rn_sbot_min                     ! set the minimum depth for the s-coordinate 
    … …  
    11901174      !                                        ! ============================= 
    11911175      ! use r-value to create hybrid coordinates 
     1176 
     1177      ! Smooth the bathymetry (if required) 
     1178      scosrf(:,:) = 0._wp             ! ocean surface depth (here zero: no under ice-shelf sea) 
     1179      scobot(:,:) = bathy(:,:)        ! ocean bottom  depth 
     1180      IF( ln_read_zenv) THEN 
     1181         WRITE(numout,*) '      Zenv is not calculated but read from Bathy File  ln_read_zenv        = ', ln_read_zenv 
     1182      ELSE 
     1183      IF ( jpnij .gt.1)  CALL ctl_stop( ' zgr_zps : ln_read_zenv=false and jpnij > 1,  Calculating zenv on more than one Proc is not safe, calculate on one proc only ' )    
     1184 
    11921185      DO jj = 1, jpj 
    11931186         DO ji = 1, jpi 
    … …  
    11961189      END DO 
    11971190      !  
    1198       ! Smooth the bathymetry (if required) 
    1199       scosrf(:,:) = 0._wp             ! ocean surface depth (here zero: no under ice-shelf sea) 
    1200       scobot(:,:) = bathy(:,:)        ! ocean bottom  depth 
    12011191      ! 
    12021192      jl = 0 
    … …  
    12701260      ! 
    12711261      !                                        ! envelop bathymetry saved in hbatt 
     1262      ENDIF       ! End of IF block for reading from a file or calculating zenv 
    12721263      hbatt(:,:) = zenv(:,:)  
    12731264      IF( MINVAL( gphit(:,:) ) * MAXVAL( gphit(:,:) ) <= 0._wp ) THEN 
    … …  
    13651356      ! non-dimensional "sigma" for model level depth at w- and t-levels 
    13661357 
    1367       IF( ln_s_sigma ) THEN        ! Song and Haidvogel style stretched sigma for depths 
    1368          !                         ! below rn_hc, with uniform sigma in shallower waters 
    1369          DO ji = 1, jpi 
    1370             DO jj = 1, jpj 
    1371  
    1372                IF( hbatt(ji,jj) > rn_hc ) THEN    !deep water, stretched sigma 
    1373                   DO jk = 1, jpk 
    1374                      gsigw3(ji,jj,jk) = -fssig1( REAL(jk,wp)-0.5_wp, rn_bb ) 
    1375                      gsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp)       , rn_bb ) 
    1376                   END DO 
    1377                ELSE ! shallow water, uniform sigma 
    1378                   DO jk = 1, jpk 
    1379                      gsigw3(ji,jj,jk) =   REAL(jk-1,wp)            / REAL(jpk-1,wp) 
    1380                      gsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) 
    1381                   END DO 
    1382                ENDIF 
    1383                IF( nprint == 1 .AND. lwp )   WRITE(numout,*) 'gsigw3 1 jpk    ', gsigw3(ji,jj,1), gsigw3(ji,jj,jpk) 
    1384                ! 
    1385                DO jk = 1, jpkm1 
    1386                   esigt3(ji,jj,jk  ) = gsigw3(ji,jj,jk+1) - gsigw3(ji,jj,jk) 
    1387                   esigw3(ji,jj,jk+1) = gsigt3(ji,jj,jk+1) - gsigt3(ji,jj,jk) 
    1388                END DO 
    1389                esigw3(ji,jj,1  ) = 2._wp * ( gsigt3(ji,jj,1  ) - gsigw3(ji,jj,1  ) ) 
    1390                esigt3(ji,jj,jpk) = 2._wp * ( gsigt3(ji,jj,jpk) - gsigw3(ji,jj,jpk) ) 
    1391                ! 
    1392                ! Coefficients for vertical depth as the sum of e3w scale factors 
    1393                gsi3w3(ji,jj,1) = 0.5_wp * esigw3(ji,jj,1) 
    1394                DO jk = 2, jpk 
    1395                   gsi3w3(ji,jj,jk) = gsi3w3(ji,jj,jk-1) + esigw3(ji,jj,jk) 
    1396                END DO 
    1397                ! 
    1398                DO jk = 1, jpk 
    1399                   zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
    1400                   zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
    1401                   gdept (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 
    1402                   gdepw (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 
    1403                   gdep3w(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 
    1404                END DO 
    1405                ! 
    1406             END DO   ! for all jj's 
    1407          END DO    ! for all ji's 
    1408  
    1409          DO ji = 1, jpim1 
    1410             DO jj = 1, jpjm1 
    1411                DO jk = 1, jpk 
    1412                   esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk) )   & 
    1413                      &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
    1414                   esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji,jj+1)*esigt3(ji,jj+1,jk) )   & 
    1415                      &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
    1416                   esigtf3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk)     & 
    1417                      &                + hbatt(ji,jj+1)*esigt3(ji,jj+1,jk)+hbatt(ji+1,jj+1)*esigt3(ji+1,jj+1,jk) )   & 
    1418                      &              / ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 
    1419                   esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji+1,jj)*esigw3(ji+1,jj,jk) )   & 
    1420                      &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
    1421                   esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji,jj+1)*esigw3(ji,jj+1,jk) )   & 
    1422                      &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
    1423                   ! 
    1424                   e3t(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*esigt3 (ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1425                   e3u(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*esigtu3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1426                   e3v(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*esigtv3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1427                   e3f(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*esigtf3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1428                   ! 
    1429                   e3w (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*esigw3 (ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1430                   e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*esigwu3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1431                   e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*esigwv3(ji,jj,jk) + rn_hc/FLOAT(jpkm1) ) 
    1432                END DO 
    1433             END DO 
    1434          END DO 
    1435  
    1436          CALL lbc_lnk( e3t , 'T', 1._wp ) 
    1437          CALL lbc_lnk( e3u , 'U', 1._wp ) 
    1438          CALL lbc_lnk( e3v , 'V', 1._wp ) 
    1439          CALL lbc_lnk( e3f , 'F', 1._wp ) 
    1440          CALL lbc_lnk( e3w , 'W', 1._wp ) 
    1441          CALL lbc_lnk( e3uw, 'U', 1._wp ) 
    1442          CALL lbc_lnk( e3vw, 'V', 1._wp ) 
    1443  
    1444          ! 
    1445       ELSE   ! not ln_s_sigma 
    1446          ! 
    1447          DO jk = 1, jpk 
    1448            gsigw(jk) = -fssig( REAL(jk,wp)-0.5_wp ) 
    1449            gsigt(jk) = -fssig( REAL(jk,wp)        ) 
    1450          END DO 
    1451          IF( nprint == 1 .AND. lwp )   WRITE(numout,*) 'gsigw 1 jpk    ', gsigw(1), gsigw(jpk) 
    1452          ! 
    1453          ! Coefficients for vertical scale factors at w-, t- levels 
    1454 !!gm bug :  define it from analytical function, not like juste bellow.... 
    1455 !!gm        or betteroffer the 2 possibilities.... 
    1456          DO jk = 1, jpkm1 
    1457             esigt(jk  ) = gsigw(jk+1) - gsigw(jk) 
    1458             esigw(jk+1) = gsigt(jk+1) - gsigt(jk) 
    1459          END DO 
    1460          esigw( 1 ) = 2._wp * ( gsigt(1  ) - gsigw(1  ) )  
    1461          esigt(jpk) = 2._wp * ( gsigt(jpk) - gsigw(jpk) ) 
    1462  
    1463 !!gm  original form 
    1464 !!org DO jk = 1, jpk 
    1465 !!org    esigt(jk)=fsdsig( FLOAT(jk)     ) 
    1466 !!org    esigw(jk)=fsdsig( FLOAT(jk)-0.5 ) 
    1467 !!org END DO 
    1468 !!gm 
    1469          ! 
    1470          ! Coefficients for vertical depth as the sum of e3w scale factors 
    1471          gsi3w(1) = 0.5_wp * esigw(1) 
    1472          DO jk = 2, jpk 
    1473             gsi3w(jk) = gsi3w(jk-1) + esigw(jk) 
    1474          END DO 
    1475 !!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) 
    1476          DO jk = 1, jpk 
    1477             zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
    1478             zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
    1479             gdept (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsigt(jk) + hift(:,:)*zcoeft ) 
    1480             gdepw (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsigw(jk) + hift(:,:)*zcoefw ) 
    1481             gdep3w(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsi3w(jk) + hift(:,:)*zcoeft ) 
    1482          END DO 
    1483 !!gm: e3uw, e3vw can be suppressed  (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) 
    1484          DO jj = 1, jpj 
    1485             DO ji = 1, jpi 
    1486                DO jk = 1, jpk 
    1487                  e3t(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
    1488                  e3u(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
    1489                  e3v(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
    1490                  e3f(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 
    1491                  ! 
    1492                  e3w (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
    1493                  e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
    1494                  e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
    1495                END DO 
    1496             END DO 
    1497          END DO 
    1498          ! 
    1499       ENDIF ! ln_s_sigma 
    1500  
    1501  
     1358 
     1359!======================================================================== 
     1360! Song and Haidvogel  1994 (ln_s_sh94=T) 
     1361! Siddorn and Furner 2012 (ln_sf12=T) 
     1362! or  tanh function       (both false)                     
     1363!======================================================================== 
     1364      IF      ( ln_s_sh94 ) THEN  
     1365                           CALL s_sh94() 
     1366      ELSE IF ( ln_s_sf12 ) THEN 
     1367                           CALL s_sf12() 
     1368      ELSE                  
     1369                           CALL s_tanh() 
     1370      ENDIF  
     1371 
     1372      CALL lbc_lnk( e3t , 'T', 1._wp ) 
     1373      CALL lbc_lnk( e3u , 'U', 1._wp ) 
     1374      CALL lbc_lnk( e3v , 'V', 1._wp ) 
     1375      CALL lbc_lnk( e3f , 'F', 1._wp ) 
     1376      CALL lbc_lnk( e3w , 'W', 1._wp ) 
     1377      CALL lbc_lnk( e3uw, 'U', 1._wp ) 
     1378      CALL lbc_lnk( e3vw, 'V', 1._wp ) 
     1379 
     1380      fsdepw(:,:,:) = gdepw (:,:,:) 
     1381      fsde3w(:,:,:) = gdep3w(:,:,:) 
    15021382      ! 
    15031383      where (e3t   (:,:,:).eq.0.0)  e3t(:,:,:) = 1.0 
    … …  
    15571437            &                          ' w ', MAXVAL( fse3w (:,:,:) ) 
    15581438      ENDIF 
    1559       ! 
     1439      !  END DO 
    15601440      IF(lwp) THEN                                  ! selected vertical profiles 
    15611441         WRITE(numout,*) 
    … …  
    15871467      ENDIF 
    15881468 
    1589 !!gm bug?  no more necessary?  if ! defined key_helsinki 
    1590       DO jk = 1, jpk 
     1469!================================================================================ 
     1470! check the coordinate makes sense 
     1471!================================================================================ 
     1472      DO ji = 1, jpi 
    15911473         DO jj = 1, jpj 
    1592             DO ji = 1, jpi 
    1593                IF( fse3w(ji,jj,jk) <= 0._wp .OR. fse3t(ji,jj,jk) <= 0._wp ) THEN 
    1594                   WRITE(ctmp1,*) 'zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 
    1595                   CALL ctl_stop( ctmp1 ) 
    1596                ENDIF 
    1597                IF( fsdepw(ji,jj,jk) < 0._wp .OR. fsdept(ji,jj,jk) < 0._wp ) THEN 
    1598                   WRITE(ctmp1,*) 'zgr_sco :   gdepw or gdept =< 0  at point (i,j,k)= ', ji, jj, jk 
    1599                   CALL ctl_stop( ctmp1 ) 
    1600                ENDIF 
    1601             END DO 
    1602          END DO 
    1603       END DO 
    1604 !!gm bug    #endif 
    1605       ! 
    1606       CALL wrk_dealloc( jpi, jpj,      zenv, ztmp, zmsk, zri, zrj, zhbat                           ) 
     1474 
     1475            IF( hbatt(ji,jj) > 0._wp) THEN 
     1476               DO jk = 1, mbathy(ji,jj) 
     1477                 ! check coordinate is monotonically increasing 
     1478                 IF (fse3w(ji,jj,jk) <= 0._wp .OR. fse3t(ji,jj,jk) <= 0._wp ) THEN 
     1479                    WRITE(ctmp1,*) 'ERROR zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 
     1480                    WRITE(numout,*) 'ERROR zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 
     1481                    WRITE(numout,*) 'e3w',fse3w(ji,jj,:) 
     1482                    WRITE(numout,*) 'e3t',fse3t(ji,jj,:) 
     1483                    CALL ctl_stop( ctmp1 ) 
     1484                 ENDIF 
     1485                 ! and check it has never gone negative 
     1486                 IF( fsdepw(ji,jj,jk) < 0._wp .OR. fsdept(ji,jj,jk) < 0._wp ) THEN 
     1487                    WRITE(ctmp1,*) 'ERROR zgr_sco :   gdepw or gdept =< 0  at point (i,j,k)= ', ji, jj, jk 
     1488                    WRITE(numout,*) 'ERROR zgr_sco :   gdepw   or gdept   =< 0  at point (i,j,k)= ', ji, jj, jk 
     1489                    WRITE(numout,*) 'gdepw',fsdepw(ji,jj,:) 
     1490                    WRITE(numout,*) 'gdept',fsdept(ji,jj,:) 
     1491                    CALL ctl_stop( ctmp1 ) 
     1492                 ENDIF 
     1493                 ! and check it never exceeds the total depth 
     1494                 IF( fsdepw(ji,jj,jk) > hbatt(ji,jj) ) THEN 
     1495                    WRITE(ctmp1,*) 'ERROR zgr_sco :   gdepw > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1496                    WRITE(numout,*) 'ERROR zgr_sco :   gdepw > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1497                    WRITE(numout,*) 'gdepw',fsdepw(ji,jj,:) 
     1498                    CALL ctl_stop( ctmp1 ) 
     1499                 ENDIF 
     1500               END DO 
     1501 
     1502               DO jk = 1, mbathy(ji,jj)-1 
     1503                 ! and check it never exceeds the total depth 
     1504                IF( fsdept(ji,jj,jk) > hbatt(ji,jj) ) THEN 
     1505                    WRITE(ctmp1,*) 'ERROR zgr_sco :   gdept > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1506                    WRITE(numout,*) 'ERROR zgr_sco :   gdept > hbatt  at point (i,j,k)= ', ji, jj, jk 
     1507                    WRITE(numout,*) 'gdept',fsdept(ji,jj,:) 
     1508                    CALL ctl_stop( ctmp1 ) 
     1509                 ENDIF 
     1510               END DO 
     1511 
     1512            ENDIF 
     1513 
     1514         END DO 
     1515      END DO 
     1516      ! 
     1517      CALL wrk_dealloc( jpi, jpj,       ztmp, zmsk, zri, zrj, zhbat                           ) 
    16071518      CALL wrk_dealloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
    16081519      CALL wrk_dealloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
    … …  
    16121523   END SUBROUTINE zgr_sco 
    16131524 
     1525!!====================================================================== 
     1526   SUBROUTINE s_sh94() 
     1527 
     1528      !!---------------------------------------------------------------------- 
     1529      !!                  ***  ROUTINE s_sh94  *** 
     1530      !!                      
     1531      !! ** Purpose :   stretch the s-coordinate system 
     1532      !! 
     1533      !! ** Method  :   s-coordinate stretch using the Song and Haidvogel 1994 
     1534      !!                mixed S/sigma coordinate 
     1535      !! 
     1536      !! Reference : Song and Haidvogel 1994.  
     1537      !!---------------------------------------------------------------------- 
     1538      ! 
     1539      INTEGER  ::   ji, jj, jk           ! dummy loop argument 
     1540      REAL(wp) ::   zcoeft, zcoefw   ! temporary scalars 
     1541      ! 
     1542      REAL(wp), POINTER, DIMENSION(:,:,:) :: gsigw3, gsigt3, gsi3w3 
     1543      REAL(wp), POINTER, DIMENSION(:,:,:) :: esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3            
     1544 
     1545      CALL wrk_alloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
     1546      CALL wrk_alloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
     1547 
     1548      gsigw3  = 0._wp   ;   gsigt3  = 0._wp   ;   gsi3w3  = 0._wp 
     1549      esigt3  = 0._wp   ;   esigw3  = 0._wp  
     1550      esigtu3 = 0._wp   ;   esigtv3 = 0._wp   ;   esigtf3 = 0._wp 
     1551      esigwu3 = 0._wp   ;   esigwv3 = 0._wp 
     1552 
     1553      DO ji = 1, jpi 
     1554         DO jj = 1, jpj 
     1555 
     1556            IF( hbatt(ji,jj) > rn_hc ) THEN    !deep water, stretched sigma 
     1557               DO jk = 1, jpk 
     1558                  gsigw3(ji,jj,jk) = -fssig1( REAL(jk,wp)-0.5_wp, rn_bb ) 
     1559                  gsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp)       , rn_bb ) 
     1560               END DO 
     1561            ELSE ! shallow water, uniform sigma 
     1562               DO jk = 1, jpk 
     1563                  gsigw3(ji,jj,jk) =   REAL(jk-1,wp)            / REAL(jpk-1,wp) 
     1564                  gsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) 
     1565                  END DO 
     1566            ENDIF 
     1567            ! 
     1568            DO jk = 1, jpkm1 
     1569               esigt3(ji,jj,jk  ) = gsigw3(ji,jj,jk+1) - gsigw3(ji,jj,jk) 
     1570               esigw3(ji,jj,jk+1) = gsigt3(ji,jj,jk+1) - gsigt3(ji,jj,jk) 
     1571            END DO 
     1572            esigw3(ji,jj,1  ) = 2._wp * ( gsigt3(ji,jj,1  ) - gsigw3(ji,jj,1  ) ) 
     1573            esigt3(ji,jj,jpk) = 2._wp * ( gsigt3(ji,jj,jpk) - gsigw3(ji,jj,jpk) ) 
     1574            ! 
     1575            ! Coefficients for vertical depth as the sum of e3w scale factors 
     1576            gsi3w3(ji,jj,1) = 0.5_wp * esigw3(ji,jj,1) 
     1577            DO jk = 2, jpk 
     1578               gsi3w3(ji,jj,jk) = gsi3w3(ji,jj,jk-1) + esigw3(ji,jj,jk) 
     1579            END DO 
     1580            ! 
     1581            DO jk = 1, jpk 
     1582               zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
     1583               zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
     1584               gdept (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 
     1585               gdepw (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 
     1586               gdep3w(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 
     1587            END DO 
     1588           ! 
     1589         END DO   ! for all jj's 
     1590      END DO    ! for all ji's 
     1591 
     1592      DO ji = 1, jpim1 
     1593         DO jj = 1, jpjm1 
     1594            DO jk = 1, jpk 
     1595               esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk) )   & 
     1596                  &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1597               esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji,jj+1)*esigt3(ji,jj+1,jk) )   & 
     1598                  &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1599               esigtf3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk)     & 
     1600                  &                + hbatt(ji,jj+1)*esigt3(ji,jj+1,jk)+hbatt(ji+1,jj+1)*esigt3(ji+1,jj+1,jk) )   & 
     1601                  &              / ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 
     1602               esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji+1,jj)*esigw3(ji+1,jj,jk) )   & 
     1603                  &              / ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1604               esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji,jj+1)*esigw3(ji,jj+1,jk) )   & 
     1605                  &              / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1606               ! 
     1607               e3t(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1608               e3u(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1609               e3v(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1610               e3f(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1611               ! 
     1612               e3w (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1613               e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1614               e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 
     1615            END DO 
     1616        END DO 
     1617      END DO 
     1618 
     1619      CALL wrk_dealloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
     1620      CALL wrk_dealloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
     1621 
     1622   END SUBROUTINE s_sh94 
     1623 
     1624   SUBROUTINE s_sf12 
     1625 
     1626      !!---------------------------------------------------------------------- 
     1627      !!                  ***  ROUTINE s_sf12 ***  
     1628      !!                      
     1629      !! ** Purpose :   stretch the s-coordinate system 
     1630      !! 
     1631      !! ** Method  :   s-coordinate stretch using the Siddorn and Furner 2012? 
     1632      !!                mixed S/sigma/Z coordinate 
     1633      !! 
     1634      !!                This method allows the maintenance of fixed surface and or 
     1635      !!                bottom cell resolutions (cf. geopotential coordinates)  
     1636      !!                within an analytically derived stretched S-coordinate framework. 
     1637      !! 
     1638      !! 
     1639      !! Reference : Siddorn and Furner 2012 (submitted Ocean modelling). 
     1640      !!---------------------------------------------------------------------- 
     1641      ! 
     1642      INTEGER  ::   ji, jj, jk           ! dummy loop argument 
     1643      REAL(wp) ::   fsmth          ! smoothing around critical depth 
     1644      REAL(wp) ::   zss, zbb       ! Surface and bottom cell thickness in sigma space 
     1645      ! 
     1646      REAL(wp), POINTER, DIMENSION(:,:,:) :: gsigw3, gsigt3, gsi3w3 
     1647      REAL(wp), POINTER, DIMENSION(:,:,:) :: esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3            
     1648 
     1649      ! 
     1650      CALL wrk_alloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
     1651      CALL wrk_alloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
     1652 
     1653      gsigw3  = 0._wp   ;   gsigt3  = 0._wp   ;   gsi3w3  = 0._wp 
     1654      esigt3  = 0._wp   ;   esigw3  = 0._wp  
     1655      esigtu3 = 0._wp   ;   esigtv3 = 0._wp   ;   esigtf3 = 0._wp 
     1656      esigwu3 = 0._wp   ;   esigwv3 = 0._wp 
     1657 
     1658      DO ji = 1, jpi 
     1659         DO jj = 1, jpj 
     1660 
     1661          IF (hbatt(ji,jj)>rn_hc) THEN !deep water, stretched sigma 
     1662               
     1663              zbb = hbatt(ji,jj)*rn_zb_a + rn_zb_b   ! this forces a linear bottom cell depth relationship with H,. 
     1664                                                     ! could be changed by users but care must be taken to do so carefully 
     1665              zbb = 1.0_wp-(zbb/hbatt(ji,jj)) 
     1666             
     1667              zss = rn_zs / hbatt(ji,jj)  
     1668               
     1669              IF (rn_efold /= 0.0_wp) THEN 
     1670                fsmth   = tanh( (hbatt(ji,jj)- rn_hc ) / rn_efold ) 
     1671              ELSE 
     1672                fsmth = 1.0_wp  
     1673              ENDIF 
     1674                
     1675              DO jk = 1, jpk 
     1676                gsigw3(ji,jj,jk) =  REAL(jk-1,wp)        /REAL(jpk-1,wp) 
     1677                gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp) 
     1678              ENDDO 
     1679              gsigw3(ji,jj,:) = fgamma( gsigw3(ji,jj,:), zbb, zss, fsmth  ) 
     1680              gsigt3(ji,jj,:) = fgamma( gsigt3(ji,jj,:), zbb, zss, fsmth  ) 
     1681  
     1682          ELSE IF (ln_sigcrit) THEN ! shallow water, uniform sigma 
     1683 
     1684            DO jk = 1, jpk 
     1685              gsigw3(ji,jj,jk) =  REAL(jk-1,wp)     /REAL(jpk-1,wp) 
     1686              gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp) 
     1687            END DO 
     1688 
     1689          ELSE  ! shallow water, z coordinates 
     1690 
     1691            DO jk = 1, jpk 
     1692              gsigw3(ji,jj,jk) =  REAL(jk-1,wp)        /REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) 
     1693              gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) 
     1694            END DO 
     1695 
     1696          ENDIF 
     1697 
     1698          DO jk = 1, jpkm1 
     1699             esigt3(ji,jj,jk) = gsigw3(ji,jj,jk+1) - gsigw3(ji,jj,jk) 
     1700             esigw3(ji,jj,jk+1) = gsigt3(ji,jj,jk+1) - gsigt3(ji,jj,jk) 
     1701          END DO 
     1702          esigw3(ji,jj,1  ) = 2.0_wp * (gsigt3(ji,jj,1  ) - gsigw3(ji,jj,1  )) 
     1703          esigt3(ji,jj,jpk) = 2.0_wp * (gsigt3(ji,jj,jpk) - gsigw3(ji,jj,jpk)) 
     1704 
     1705          ! Coefficients for vertical depth as the sum of e3w scale factors 
     1706          gsi3w3(ji,jj,1) = 0.5 * esigw3(ji,jj,1) 
     1707          DO jk = 2, jpk 
     1708             gsi3w3(ji,jj,jk) = gsi3w3(ji,jj,jk-1) + esigw3(ji,jj,jk) 
     1709          END DO 
     1710 
     1711          DO jk = 1, jpk 
     1712             gdept (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*gsigt3(ji,jj,jk) 
     1713             gdepw (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*gsigw3(ji,jj,jk) 
     1714             gdep3w(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*gsi3w3(ji,jj,jk) 
     1715          END DO 
     1716 
     1717        ENDDO   ! for all jj's 
     1718      ENDDO    ! for all ji's 
     1719 
     1720      DO ji=1,jpi 
     1721        DO jj=1,jpj 
     1722 
     1723          DO jk = 1, jpk 
     1724                esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk) ) / & 
     1725                                    ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1726                esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji,jj+1)*esigt3(ji,jj+1,jk) ) / & 
     1727                                    ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1728                esigtf3(ji,jj,jk) = ( hbatt(ji,jj)*esigt3(ji,jj,jk)+hbatt(ji+1,jj)*esigt3(ji+1,jj,jk) +  & 
     1729                                      hbatt(ji,jj+1)*esigt3(ji,jj+1,jk)+hbatt(ji+1,jj+1)*esigt3(ji+1,jj+1,jk) ) / & 
     1730                                    ( hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 
     1731                esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji+1,jj)*esigw3(ji+1,jj,jk) ) / & 
     1732                                    ( hbatt(ji,jj)+hbatt(ji+1,jj) ) 
     1733                esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*esigw3(ji,jj,jk)+hbatt(ji,jj+1)*esigw3(ji,jj+1,jk) ) / & 
     1734                                    ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 
     1735 
     1736             e3t(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*esigt3(ji,jj,jk) 
     1737             e3u(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*esigtu3(ji,jj,jk) 
     1738             e3v(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*esigtv3(ji,jj,jk) 
     1739             e3f(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*esigtf3(ji,jj,jk) 
     1740             ! 
     1741             e3w(ji,jj,jk)=hbatt(ji,jj)*esigw3(ji,jj,jk) 
     1742             e3uw(ji,jj,jk)=hbatu(ji,jj)*esigwu3(ji,jj,jk) 
     1743             e3vw(ji,jj,jk)=hbatv(ji,jj)*esigwv3(ji,jj,jk) 
     1744          END DO 
     1745 
     1746        ENDDO 
     1747      ENDDO 
     1748 
     1749      CALL wrk_dealloc( jpi, jpj, jpk, gsigw3, gsigt3, gsi3w3                                      ) 
     1750      CALL wrk_dealloc( jpi, jpj, jpk, esigt3, esigw3, esigtu3, esigtv3, esigtf3, esigwu3, esigwv3 ) 
     1751 
     1752   END SUBROUTINE s_sf12 
     1753 
     1754   SUBROUTINE s_tanh() 
     1755 
     1756      !!---------------------------------------------------------------------- 
     1757      !!                  ***  ROUTINE s_tanh***  
     1758      !!                      
     1759      !! ** Purpose :   stretch the s-coordinate system 
     1760      !! 
     1761      !! ** Method  :   s-coordinate stretch  
     1762      !! 
     1763      !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. 
     1764      !!---------------------------------------------------------------------- 
     1765 
     1766      INTEGER  ::   ji, jj, jk           ! dummy loop argument 
     1767      REAL(wp) ::   zcoeft, zcoefw   ! temporary scalars 
     1768 
     1769      DO jk = 1, jpk 
     1770        gsigw(jk) = -fssig( REAL(jk,wp)-0.5_wp ) 
     1771        gsigt(jk) = -fssig( REAL(jk,wp)        ) 
     1772      END DO 
     1773      IF( nprint == 1 .AND. lwp )   WRITE(numout,*) 'gsigw 1 jpk    ', gsigw(1), gsigw(jpk) 
     1774      ! 
     1775      ! Coefficients for vertical scale factors at w-, t- levels 
     1776!!gm bug :  define it from analytical function, not like juste bellow.... 
     1777!!gm        or betteroffer the 2 possibilities.... 
     1778      DO jk = 1, jpkm1 
     1779         esigt(jk  ) = gsigw(jk+1) - gsigw(jk) 
     1780         esigw(jk+1) = gsigt(jk+1) - gsigt(jk) 
     1781      END DO 
     1782      esigw( 1 ) = 2._wp * ( gsigt(1  ) - gsigw(1  ) )  
     1783      esigt(jpk) = 2._wp * ( gsigt(jpk) - gsigw(jpk) ) 
     1784      ! 
     1785      ! Coefficients for vertical depth as the sum of e3w scale factors 
     1786      gsi3w(1) = 0.5_wp * esigw(1) 
     1787      DO jk = 2, jpk 
     1788         gsi3w(jk) = gsi3w(jk-1) + esigw(jk) 
     1789      END DO 
     1790!!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) 
     1791      DO jk = 1, jpk 
     1792         zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 
     1793         zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 
     1794         gdept (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsigt(jk) + hift(:,:)*zcoeft ) 
     1795         gdepw (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsigw(jk) + hift(:,:)*zcoefw ) 
     1796         gdep3w(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*gsi3w(jk) + hift(:,:)*zcoeft ) 
     1797      END DO 
     1798!!gm: e3uw, e3vw can be suppressed  (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) 
     1799      DO jj = 1, jpj 
     1800         DO ji = 1, jpi 
     1801            DO jk = 1, jpk 
     1802              e3t(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
     1803              e3u(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
     1804              e3v(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
     1805              e3f(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 
     1806              ! 
     1807              e3w (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 
     1808              e3uw(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 
     1809              e3vw(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 
     1810            END DO 
     1811         END DO 
     1812      END DO 
     1813   END SUBROUTINE s_tanh 
     1814 
     1815   FUNCTION fssig( pk ) RESULT( pf ) 
     1816      !!---------------------------------------------------------------------- 
     1817      !!                 ***  ROUTINE fssig *** 
     1818      !!        
     1819      !! ** Purpose :   provide the analytical function in s-coordinate 
     1820      !!           
     1821      !! ** Method  :   the function provide the non-dimensional position of 
     1822      !!                T and W (i.e. between 0 and 1) 
     1823      !!                T-points at integer values (between 1 and jpk) 
     1824      !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
     1825      !!---------------------------------------------------------------------- 
     1826      REAL(wp), INTENT(in) ::   pk   ! continuous "k" coordinate 
     1827      REAL(wp)             ::   pf   ! sigma value 
     1828      !!---------------------------------------------------------------------- 
     1829      ! 
     1830      pf =   (   TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb )  )   & 
     1831         &     - TANH( rn_thetb * rn_theta                                )  )   & 
     1832         & * (   COSH( rn_theta                           )                      & 
     1833         &     + COSH( rn_theta * ( 2._wp * rn_thetb - 1._wp ) )  )              & 
     1834         & / ( 2._wp * SINH( rn_theta ) ) 
     1835      ! 
     1836   END FUNCTION fssig 
     1837 
     1838 
     1839   FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) 
     1840      !!---------------------------------------------------------------------- 
     1841      !!                 ***  ROUTINE fssig1 *** 
     1842      !! 
     1843      !! ** Purpose :   provide the Song and Haidvogel version of the analytical function in s-coordinate 
     1844      !! 
     1845      !! ** Method  :   the function provides the non-dimensional position of 
     1846      !!                T and W (i.e. between 0 and 1) 
     1847      !!                T-points at integer values (between 1 and jpk) 
     1848      !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
     1849      !!---------------------------------------------------------------------- 
     1850      REAL(wp), INTENT(in) ::   pk1   ! continuous "k" coordinate 
     1851      REAL(wp), INTENT(in) ::   pbb   ! Stretching coefficient 
     1852      REAL(wp)             ::   pf1   ! sigma value 
     1853      !!---------------------------------------------------------------------- 
     1854      ! 
     1855      IF ( rn_theta == 0 ) then      ! uniform sigma 
     1856         pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 
     1857      ELSE                        ! stretched sigma 
     1858         pf1 =   ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta )              & 
     1859            &  + pbb * (  (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta )  )  & 
     1860            &        / ( 2._wp * TANH( 0.5_wp * rn_theta ) )  ) 
     1861      ENDIF 
     1862      ! 
     1863   END FUNCTION fssig1 
     1864 
     1865 
     1866   FUNCTION fgamma( pk1, Zbb, Zss, F ) RESULT( gam ) 
     1867      !!---------------------------------------------------------------------- 
     1868      !!                 ***  ROUTINE fgamma  *** 
     1869      !! 
     1870      !! ** Purpose :   provide analytical function for the s-coordinate 
     1871      !! 
     1872      !! ** Method  :   the function provides the non-dimensional position of 
     1873      !!                T and W (i.e. between 0 and 1) 
     1874      !!                T-points at integer values (between 1 and jpk) 
     1875      !!                W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 
     1876      !! 
     1877      !!                This method allows the maintenance of fixed surface and or 
     1878      !!                bottom cell resolutions (cf. geopotential coordinates)  
     1879      !!                within an analytically derived stretched S-coordinate framework. 
     1880      !! 
     1881      !! Reference  :   Siddorn and Furner, in prep 
     1882      !!---------------------------------------------------------------------- 
     1883      REAL(wp), INTENT(in   ) ::   pk1(jpk)   ! continuous "k" coordinate 
     1884      REAL(wp)                ::   gam(jpk)   ! stretched coordinate 
     1885      REAL(wp), INTENT(in   ) ::   Zbb      ! Bottom box depth 
     1886      REAL(wp), INTENT(in   ) ::   Zss      ! surface box depth 
     1887      REAL(wp), INTENT(in   ) ::   F        ! Smoothing parameter 
     1888      REAL(wp)                ::   a1,a2,a3 ! local variables 
     1889      REAL(wp)                ::   n1,n2    ! local variables 
     1890      REAL(wp)                ::   A,B,X    ! local variables 
     1891      integer                 ::   jk 
     1892      !!---------------------------------------------------------------------- 
     1893      ! 
     1894 
     1895      n1  =  1./(jpk-1.) 
     1896      n2  =  1. -  n1 
     1897 
     1898      a1 = (rn_alpha+2.0_wp)*n1**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*n1**(rn_alpha+2.0_wp)  
     1899      a2 = (rn_alpha+2.0_wp)*n2**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*n2**(rn_alpha+2.0_wp) 
     1900      a3 = ( n2**3.0_wp - a2)/( n1**3.0_wp - a1) 
     1901      
     1902      A = Zbb - a3*(Zss-a1)-a2 
     1903      A = A/( n2-0.5_wp*(a2+n2**2.0_wp) - a3*(n1-0.5_wp*(a1+n1**2.0_wp) ) ) 
     1904      B = (Zss - a1 - A*( n1-0.5_wp*(a1+n1**2.0_wp ) ) ) / (n1**3.0_wp - a1) 
     1905      X = 1.0_wp-A/2.0_wp-B 
     1906  
     1907      DO jk = 1, jpk 
     1908        gam(jk) = A*(pk1(jk)*(1.0_wp-pk1(jk)/2.0_wp))+B*pk1(jk)**3.0_wp + X*( (rn_alpha+2.0_wp)*pk1(jk)**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*pk1(jk)**(rn_alpha+2.0_wp) ) 
     1909        gam(jk) = gam(jk)*F+pk1(jk)*(1.0_wp-F) 
     1910      ENDDO  
     1911 
     1912      ! 
     1913   END FUNCTION fgamma 
     1914 
    16141915   !!====================================================================== 
    16151916END MODULE domzgr 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr_substitute.h90

    r7363 r7367  
    88   !!            3.1  !  2009-02  (G. Madec, M. Leclair)  pure z* coordinate 
    99   !!---------------------------------------------------------------------- 
     10#if defined key_zco 
     11! reference for pure z-coordinate (1D - no i,j and time dependency) 
     12#   define  fsdept_0(i,j,k)  gdept_0(k) 
     13#   define  fsdepw_0(i,j,k)  gdepw_0(k) 
     14#   define  fsde3w_0(i,j,k)  gdepw_0(k) 
     15#   define  fse3t_0(i,j,k)   e3t_0(k) 
     16#   define  fse3u_0(i,j,k)   e3t_0(k) 
     17#   define  fse3v_0(i,j,k)   e3t_0(k) 
     18#   define  fse3f_0(i,j,k)   e3t_0(k) 
     19#   define  fse3w_0(i,j,k)   e3w_0(k) 
     20#   define  fse3uw_0(i,j,k)  e3w_0(k) 
     21#   define  fse3vw_0(i,j,k)  e3w_0(k) 
     22#else 
    1023! reference for s- or zps-coordinate (3D no time dependency) 
    1124#   define  fsdept_0(i,j,k)  gdept(i,j,k) 
    … …  
    1932#   define  fse3uw_0(i,j,k)  e3uw(i,j,k) 
    2033#   define  fse3vw_0(i,j,k)  e3vw(i,j,k) 
     34#endif 
    2135#if defined key_vvl 
    2236! s* or z*-coordinate (3D + time dependency) + use of additional now arrays (..._1) 
    … …  
    3246#   define  fse3vw(i,j,k)  e3vw_1(i,j,k) 
    3347 
    34 #   define  fse3t_b(i,j,k)   e3t_b(i,j,k) 
    35 #   define  fse3u_b(i,j,k)   e3u_b(i,j,k) 
    36 #   define  fse3v_b(i,j,k)   e3v_b(i,j,k) 
     48#   define  fsdept_b(i,j,k)  (fsdept_0(i,j,k)*(1.+sshb(i,j)*mut(i,j,k))) 
     49#   define  fsdepw_b(i,j,k)  (fsdepw_0(i,j,k)*(1.+sshb(i,j)*mut(i,j,k))) 
     50#   define  fsde3w_b(i,j,k)  (fsde3w_0(i,j,k)*(1.+sshb(i,j)*mut(i,j,k))-sshb(i,j)) 
     51#   define  fse3t_b(i,j,k)   (fse3t_0(i,j,k)*(1.+sshb(i,j)*mut(i,j,k))) 
     52#   define  fse3u_b(i,j,k)   (fse3u_0(i,j,k)*(1.+sshu_b(i,j)*muu(i,j,k))) 
     53#   define  fse3v_b(i,j,k)   (fse3v_0(i,j,k)*(1.+sshv_b(i,j)*muv(i,j,k))) 
     54#   define  fse3f_b(i,j,k)   (fse3f_0(i,j,k)*(1.+sshf_b(i,j)*muf(i,j,k))) 
     55#   define  fse3w_b(i,j,k)   (fse3w_0(i,j,k)*(1.+sshb(i,j)*mut(i,j,k))) 
    3756#   define  fse3uw_b(i,j,k)  (fse3uw_0(i,j,k)*(1.+sshu_b(i,j)*muu(i,j,k))) 
    3857#   define  fse3vw_b(i,j,k)  (fse3vw_0(i,j,k)*(1.+sshv_b(i,j)*muv(i,j,k))) 
    … …  
    5170#   define  fse3t_m(i,j,k)   (fse3t_0(i,j,k)*(1.+ssh_m(i,j)*mut(i,j,k))) 
    5271 
     72#   define  fsdept_a(i,j,k)  (fsdept_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))) 
     73#   define  fsdepw_a(i,j,k)  (fsdepw_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))) 
     74#   define  fsde3w_a(i,j,k)  (fsde3w_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))-ssha(i,j)) 
    5375#   define  fse3t_a(i,j,k)   (fse3t_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))) 
    5476#   define  fse3u_a(i,j,k)   (fse3u_0(i,j,k)*(1.+sshu_a(i,j)*muu(i,j,k))) 
    5577#   define  fse3v_a(i,j,k)   (fse3v_0(i,j,k)*(1.+sshv_a(i,j)*muv(i,j,k))) 
     78#   define  fse3f_a(i,j,k)   (fse3f_0(i,j,k)*(1.+sshf_a(i,j)*muf(i,j,k))) 
     79#   define  fse3w_a(i,j,k)   (fse3w_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))) 
     80#   define  fse3uw_a(i,j,k)  (fse3uw_0(i,j,k)*(1.+sshu_a(i,j)*muu(i,j,k))) 
     81#   define  fse3vw_a(i,j,k)  (fse3vw_0(i,j,k)*(1.+sshv_a(i,j)*muv(i,j,k))) 
    5682 
    5783#else 
    … …  
    6894#   define  fse3vw(i,j,k)  fse3vw_0(i,j,k) 
    6995 
     96#   define  fsdept_b(i,j,k)  fsdept_0(i,j,k) 
     97#   define  fsdepw_b(i,j,k)  fsdepw_0(i,j,k) 
     98#   define  fsde3w_b(i,j,k)  fsde3w_0(i,j,k) 
    7099#   define  fse3t_b(i,j,k)   fse3t_0(i,j,k) 
    71100#   define  fse3u_b(i,j,k)   fse3u_0(i,j,k) 
    72101#   define  fse3v_b(i,j,k)   fse3v_0(i,j,k) 
     102#   define  fse3f_b(i,j,k)   fse3f_0(i,j,k) 
     103#   define  fse3w_b(i,j,k)   fse3w_0(i,j,k) 
    73104#   define  fse3uw_b(i,j,k)  fse3uw_0(i,j,k) 
    74105#   define  fse3vw_b(i,j,k)  fse3vw_0(i,j,k) 
    … …  
    87118#   define  fse3t_m(i,j,k)   fse3t_0(i,j,k) 
    88119 
     120#   define  fsdept_a(i,j,k)  fsdept_0(i,j,k) 
     121#   define  fsdepw_a(i,j,k)  fsdepw_0(i,j,k) 
     122#   define  fsde3w_a(i,j,k)  fsde3w_0(i,j,k) 
    89123#   define  fse3t_a(i,j,k)   fse3t_0(i,j,k) 
    90124#   define  fse3u_a(i,j,k)   fse3u_0(i,j,k) 
    91125#   define  fse3v_a(i,j,k)   fse3v_0(i,j,k) 
     126#   define  fse3f_a(i,j,k)   fse3f_0(i,j,k) 
     127#   define  fse3w_a(i,j,k)   fse3w_0(i,j,k) 
     128#   define  fse3uw_a(i,j,k)  fse3uw_0(i,j,k) 
     129#   define  fse3vw_a(i,j,k)  fse3vw_0(i,j,k) 
    92130#endif 
    93131   !!---------------------------------------------------------------------- 
    94    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     132   !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)  
    95133   !! $Id$ 
    96    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     134   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    97135   !!---------------------------------------------------------------------- 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r7363 r7367  
    9090         CALL rst_read                           ! Read the restart file 
    9191         !                                       ! define e3u_b, e3v_b from e3t_b read in restart file 
    92          CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
     92!revert to 3.2         CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
    9393         CALL day_init                           ! model calendar (using both namelist and restart infos) 
    9494      ELSE 
    … …  
    107107         ! 
    108108         !                                       ! define e3u_b, e3v_b from e3t_b initialized in domzgr 
    109          CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
     109!revert to 3.2         CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
    110110         ! 
    111111         IF( cp_cfg == 'eel' ) THEN 
    … …  
    128128         !    
    129129         ! - ML - sshn could be modified by istate_eel, so that initialization of fse3t_b is done here 
    130          IF( lk_vvl ) THEN 
    131             DO jk = 1, jpk 
    132                fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
    133             ENDDO 
    134          ENDIF 
     130!revert to 3.2         IF( lk_vvl ) THEN 
     131!revert to 3.2            DO jk = 1, jpk 
     132!revert to 3.2               fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
     133!revert to 3.2            ENDDO 
     134!revert to 3.2         ENDIF 
    135135         !  
    136136      ENDIF 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r7363 r7367  
    678678      REAL(wp) :: zrhdt1  
    679679      REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 
    680       INTEGER  :: zbhitwe, zbhitns 
    681       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdeptht, zrhh  
     680      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zdept, zrhh  
    682681      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp 
    683682      !!---------------------------------------------------------------------- 
    684683      ! 
    685684      CALL wrk_alloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp )  
    686       CALL wrk_alloc( jpi,jpj,jpk, zdeptht, zrhh )  
     685      CALL wrk_alloc( jpi,jpj,jpk, zdept, zrhh )  
    687686      ! 
    688687      IF( kt == nit000 ) THEN 
    … …  
    717716      END DO 
    718717 
    719       ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdeptht(:,:,:)" 
    720       DO jj = 1, jpj 
    721         DO ji = 1, jpi 
    722           zdeptht(ji,jj,1) = 0.5_wp * fse3w(ji,jj,1) 
    723           zdeptht(ji,jj,1) = zdeptht(ji,jj,1) - sshn(ji,jj) * znad 
    724           DO jk = 2, jpk 
    725              zdeptht(ji,jj,jk) = zdeptht(ji,jj,jk-1) + fse3w(ji,jj,jk) 
    726           END DO 
    727         END DO 
    728       END DO 
    729  
    730       DO jk = 1, jpkm1 
    731         DO jj = 1, jpj 
    732           DO ji = 1, jpi 
    733             fsp(ji,jj,jk) = zrhh(ji,jj,jk) 
    734             xsp(ji,jj,jk) = zdeptht(ji,jj,jk) 
    735           END DO 
    736         END DO 
    737       END DO 
     718      ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)" 
     719      DO jj = 1, jpj;   DO ji = 1, jpi 
     720          zdept(ji,jj,1) = 0.5_wp * fse3w(ji,jj,1) - sshn(ji,jj) * znad 
     721      END DO        ;   END DO 
     722 
     723      DO jk = 2, jpk;   DO jj = 1, jpj;   DO ji = 1, jpi 
     724          zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + fse3w(ji,jj,jk) 
     725      END DO        ;   END DO        ;   END DO 
     726 
     727      fsp(:,:,:) = zrhh(:,:,:) 
     728      xsp(:,:,:) = zdept(:,:,:) 
    738729 
    739730      ! Construct the vertical density profile with the  
    … …  
    745736      DO jj = 2, jpj 
    746737        DO ji = 2, jpi  
    747           zrhdt1 = zrhh(ji,jj,1) - interp3(zdeptht(ji,jj,1),asp(ji,jj,1), & 
     738          zrhdt1 = zrhh(ji,jj,1) - interp3(zdept(ji,jj,1),asp(ji,jj,1), & 
    748739                                         bsp(ji,jj,1),   csp(ji,jj,1), & 
    749                                          dsp(ji,jj,1) ) * 0.5_wp * zdeptht(ji,jj,1) 
    750           zrhdt1 = MAX(zrhdt1, 1000._wp - rau0)        ! no lighter than fresh water 
     740                                         dsp(ji,jj,1) ) * 0.25_wp * fse3w(ji,jj,1) 
    751741 
    752742          ! assuming linear profile across the top half surface layer 
    … …  
    760750          DO ji = 2, jpi 
    761751            zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) +                          & 
    762                              integ2(zdeptht(ji,jj,jk-1), zdeptht(ji,jj,jk),& 
     752                             integ_spline(zdept(ji,jj,jk-1), zdept(ji,jj,jk),& 
    763753                                    asp(ji,jj,jk-1),    bsp(ji,jj,jk-1), & 
    764754                                    csp(ji,jj,jk-1),    dsp(ji,jj,jk-1)) 
    … …  
    793783      END DO 
    794784 
     785      DO jk = 1, jpkm1 
     786        DO jj = 2, jpjm1 
     787          DO ji = 2, jpim1 
     788            zu(ji,jj,jk) = min(zu(ji,jj,jk), max(-zdept(ji,jj,jk), -zdept(ji+1,jj,jk))) 
     789            zu(ji,jj,jk) = max(zu(ji,jj,jk), min(-zdept(ji,jj,jk), -zdept(ji+1,jj,jk))) 
     790            zv(ji,jj,jk) = min(zv(ji,jj,jk), max(-zdept(ji,jj,jk), -zdept(ji,jj+1,jk))) 
     791            zv(ji,jj,jk) = max(zv(ji,jj,jk), min(-zdept(ji,jj,jk), -zdept(ji,jj+1,jk))) 
     792          END DO 
     793        END DO 
     794      END DO 
     795 
     796 
    795797      DO jk = 1, jpkm1                                   
    796798        DO jj = 2, jpjm1      
    … …  
    803805            !!!!!     for u equation 
    804806            IF( jk <= mbku(ji,jj) ) THEN 
    805                IF( -zdeptht(ji+1,jj,mbku(ji,jj)) >= -zdeptht(ji,jj,mbku(ji,jj)) ) THEN 
     807               IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN 
    806808                 jis = ji + 1; jid = ji 
    807809               ELSE 
    … …  
    811813               ! integrate the pressure on the shallow side 
    812814               jk1 = jk  
    813                zbhitwe = 0 
    814                DO WHILE ( -zdeptht(jis,jj,jk1) > zuijk ) 
     815               DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) 
    815816                 IF( jk1 == mbku(ji,jj) ) THEN 
    816                    zbhitwe = 1 
     817                   zuijk = -zdept(jis,jj,jk1) 
    817818                   EXIT 
    818819                 ENDIF 
    819                  zdeps = MIN(zdeptht(jis,jj,jk1+1), -zuijk) 
     820                 zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) 
    820821                 zpwes = zpwes +                                    &  
    821                       integ2(zdeptht(jis,jj,jk1), zdeps,            & 
     822                      integ_spline(zdept(jis,jj,jk1), zdeps,            & 
    822823                             asp(jis,jj,jk1),    bsp(jis,jj,jk1), & 
    823824                             csp(jis,jj,jk1),    dsp(jis,jj,jk1)) 
    … …  
    825826               END DO 
    826827             
    827                IF(zbhitwe == 1) THEN 
    828                  zuijk = -zdeptht(jis,jj,jk1) 
    829                ENDIF 
    830  
    831828               ! integrate the pressure on the deep side 
    832829               jk1 = jk  
    833                zbhitwe = 0 
    834                DO WHILE ( -zdeptht(jid,jj,jk1) < zuijk ) 
     830               DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) 
    835831                 IF( jk1 == 1 ) THEN 
    836                    zbhitwe = 1 
     832                   zdeps = zdept(jid,jj,1) + MIN(zuijk, sshn(jid,jj)*znad) 
     833                   zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), & 
     834                                                     bsp(jid,jj,1),   csp(jid,jj,1), & 
     835                                                     dsp(jid,jj,1)) * zdeps 
     836                   zpwed  = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps 
    837837                   EXIT 
    838838                 ENDIF 
    839                  zdeps = MAX(zdeptht(jid,jj,jk1-1), -zuijk) 
     839                 zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) 
    840840                 zpwed = zpwed +                                        &  
    841                         integ2(zdeps,              zdeptht(jid,jj,jk1), & 
     841                        integ_spline(zdeps,              zdept(jid,jj,jk1), & 
    842842                               asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1),  & 
    843843                               csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) ) 
    … …  
    845845               END DO 
    846846             
    847                IF( zbhitwe == 1 ) THEN 
    848                  zdeps = zdeptht(jid,jj,1) + MIN(zuijk, sshn(jid,jj)*znad) 
    849                  zrhdt1 = zrhh(jid,jj,1) - interp3(zdeptht(jid,jj,1), asp(jid,jj,1), & 
    850                                                  bsp(jid,jj,1),    csp(jid,jj,1), & 
    851                                                  dsp(jid,jj,1)) * zdeps 
    852                  zrhdt1 = MAX(zrhdt1, 1000._wp - rau0)        ! no lighter than fresh water 
    853                  zpwed  = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps 
    854                ENDIF 
    855  
    856847               ! update the momentum trends in u direction 
    857848 
    … …  
    870861            !!!!!     for v equation 
    871862            IF( jk <= mbkv(ji,jj) ) THEN 
    872                IF( -zdeptht(ji,jj+1,mbkv(ji,jj)) >= -zdeptht(ji,jj,mbkv(ji,jj)) ) THEN 
     863               IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN 
    873864                 jjs = jj + 1; jjd = jj 
    874865               ELSE 
    … …  
    878869               ! integrate the pressure on the shallow side 
    879870               jk1 = jk  
    880                zbhitns = 0 
    881                DO WHILE ( -zdeptht(ji,jjs,jk1) > zvijk ) 
     871               DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) 
    882872                 IF( jk1 == mbkv(ji,jj) ) THEN 
    883                    zbhitns = 1 
     873                   zvijk = -zdept(ji,jjs,jk1) 
    884874                   EXIT 
    885875                 ENDIF 
    886                  zdeps = MIN(zdeptht(ji,jjs,jk1+1), -zvijk) 
     876                 zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) 
    887877                 zpnss = zpnss +                                      &  
    888                         integ2(zdeptht(ji,jjs,jk1), zdeps,            & 
     878                        integ_spline(zdept(ji,jjs,jk1), zdeps,            & 
    889879                               asp(ji,jjs,jk1),    bsp(ji,jjs,jk1), & 
    890880                               csp(ji,jjs,jk1),    dsp(ji,jjs,jk1) ) 
    … …  
    892882               END DO 
    893883             
    894                IF(zbhitns == 1) THEN 
    895                  zvijk = -zdeptht(ji,jjs,jk1) 
    896                ENDIF 
    897  
    898884               ! integrate the pressure on the deep side 
    899885               jk1 = jk  
    900                zbhitns = 0 
    901                DO WHILE ( -zdeptht(ji,jjd,jk1) < zvijk ) 
     886               DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) 
    902887                 IF( jk1 == 1 ) THEN 
    903                    zbhitns = 1 
     888                   zdeps = zdept(ji,jjd,1) + MIN(zvijk, sshn(ji,jjd)*znad) 
     889                   zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), & 
     890                                                     bsp(ji,jjd,1),   csp(ji,jjd,1), & 
     891                                                     dsp(ji,jjd,1) ) * zdeps 
     892                   zpnsd  = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps 
    904893                   EXIT 
    905894                 ENDIF 
    906                  zdeps = MAX(zdeptht(ji,jjd,jk1-1), -zvijk) 
     895                 zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) 
    907896                 zpnsd = zpnsd +                                        &  
    908                         integ2(zdeps,              zdeptht(ji,jjd,jk1), & 
     897                        integ_spline(zdeps,              zdept(ji,jjd,jk1), & 
    909898                               asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & 
    910899                               csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) ) 
    … …  
    912901               END DO 
    913902             
    914                IF( zbhitns == 1 ) THEN 
    915                  zdeps = zdeptht(ji,jjd,1) + MIN(zvijk, sshn(ji,jjd)*znad) 
    916                  zrhdt1 = zrhh(ji,jjd,1) - interp3(zdeptht(ji,jjd,1), asp(ji,jjd,1), & 
    917                                                  bsp(ji,jjd,1),    csp(ji,jjd,1), & 
    918                                                  dsp(ji,jjd,1) ) * zdeps 
    919                  zrhdt1 = MAX(zrhdt1, 1000._wp - rau0)        ! no lighter than fresh water 
    920                  zpnsd  = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps 
    921                ENDIF 
    922903 
    923904               ! update the momentum trends in v direction 
    … …  
    941922      ! 
    942923      CALL wrk_dealloc( jpi,jpj,jpk, zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp )  
    943       CALL wrk_dealloc( jpi,jpj,jpk, zdeptht, zrhh )  
     924      CALL wrk_dealloc( jpi,jpj,jpk, zdept, zrhh )  
    944925      ! 
    945926   END SUBROUTINE hpg_prj 
    … …  
    11211102 
    11221103    
    1123    FUNCTION integ2(xl, xr, a, b, c, d)  RESULT(f)  
     1104   FUNCTION integ_spline(xl, xr, a, b, c, d)  RESULT(f)  
    11241105      !!---------------------------------------------------------------------- 
    11251106      !!                 ***  ROUTINE interp1  *** 
    … …  
    11431124         & xl * ( a + xl * ( za1 + xl * ( za2 + za3 * xl ) ) ) 
    11441125 
    1145    END FUNCTION integ2 
     1126   END FUNCTION integ_spline 
    11461127 
    11471128 
    11481129   !!====================================================================== 
    11491130END MODULE dynhpg 
     1131 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf.F90

    r7363 r7367  
    7474      CASE ( 2 )    ;   CALL dyn_ldf_bilap  ( kt )      ! iso-level bilaplacian 
    7575      CASE ( 3 )    ;   CALL dyn_ldf_bilapg ( kt )      ! s-coord. horizontal bilaplacian 
    76       CASE ( 4 )                                        ! iso-level laplacian + bilaplacian 
    77          CALL dyn_ldf_lap    ( kt ) 
    78          CALL dyn_ldf_bilap  ( kt ) 
    79       CASE ( 5 )                                        ! rotated laplacian + bilaplacian (s-coord) 
    80          CALL dyn_ldf_iso    ( kt ) 
    81          CALL dyn_ldf_bilapg ( kt ) 
     76      CASE ( 4 )                                        ! iso-level laplacian + bilaplacian   
     77        IF ( ln_zco .or. ln_zps ) THEN                ! z-coordinate   
     78           CALL dyn_ldf_lap    ( kt )   
     79           CALL dyn_ldf_bilap  ( kt )   
     80        ELSEIF ( ln_sco ) THEN             ! s-coordinate   
     81           IF ( ln_dynldf_lap_hor .or. ln_dynldf_lap_iso ) THEN   
     82               CALL dyn_ldf_iso    ( kt )   
     83           ELSEIF (ln_dynldf_lap_level ) THEN   
     84               CALL dyn_ldf_lap    ( kt )   
     85           ELSE   
     86               WRITE(numout,*) 'error in dynldf.F90, no slope used for laplacian mixing'   
     87           ENDIF   
     88           IF ( ln_dynldf_bilap_hor .or. ln_dynldf_bilap_iso ) THEN   
     89               CALL dyn_ldf_bilapg ( kt )   
     90           ELSEIF ( ln_dynldf_bilap_level ) THEN   
     91               CALL dyn_ldf_bilap  ( kt )   
     92           ELSE   
     93               WRITE(numout,*) 'error in dynldf.F90, no slope used for bilaplacian mixing'   
     94           ENDIF   
     95        ENDIF   
    8296      ! 
    8397      CASE ( -1 )                                       ! esopa: test all possibility with control print 
    … …  
    136150         WRITE(numout,*) '          laplacian operator          ln_dynldf_lap   = ', ln_dynldf_lap 
    137151         WRITE(numout,*) '          bilaplacian operator        ln_dynldf_bilap = ', ln_dynldf_bilap 
    138          WRITE(numout,*) '          iso-level                   ln_dynldf_level = ', ln_dynldf_level 
    139          WRITE(numout,*) '          horizontal (geopotential)   ln_dynldf_hor   = ', ln_dynldf_hor 
    140          WRITE(numout,*) '          iso-neutral                 ln_dynldf_iso   = ', ln_dynldf_iso 
     152         WRITE(numout,*) '          laplacien iso-level                   ln_dynldf_lap_level = ', ln_dynldf_lap_level   
     153         WRITE(numout,*) '          laplacien horizontal (geopotential)   ln_dynldf_lap_hor   = ', ln_dynldf_lap_hor   
     154         WRITE(numout,*) '          laplacien iso-neutral                 ln_dynldf_lap_iso   = ', ln_dynldf_lap_iso   
     155         WRITE(numout,*) '          bilaplacien iso-level                 ln_dynldf_bilap_level = ', ln_dynldf_bilap_level   
     156         WRITE(numout,*) '          bilaplacien horizontal (geopotential) ln_dynldf_bilap_hor   = ', ln_dynldf_bilap_hor   
     157         WRITE(numout,*) '          bilaplacien iso-neutral               ln_dynldf_bilap_iso   = ', ln_dynldf_bilap_iso   
    141158      ENDIF 
    142159 
    … …  
    147164      IF( ioptio <  1 ) CALL ctl_warn( '          neither laplacian nor bilaplacian operator set for dynamics' ) 
    148165      ioptio = 0 
    149       IF( ln_dynldf_level )   ioptio = ioptio + 1 
    150       IF( ln_dynldf_hor   )   ioptio = ioptio + 1 
    151       IF( ln_dynldf_iso   )   ioptio = ioptio + 1 
    152       IF( ioptio >  1 ) CALL ctl_stop( '          use only ONE direction (level/hor/iso)' ) 
    153  
     166      IF( ln_dynldf_lap_level )   ioptio = ioptio + 1   
     167      IF( ln_dynldf_lap_hor   )   ioptio = ioptio + 1   
     168      IF( ln_dynldf_lap_iso   )   ioptio = ioptio + 1   
     169      IF( ( ioptio /= 1 ) .and. ln_dynldf_lap )     &   
     170                        CALL ctl_stop( '          use only ONE direction for laplacien mixing (level/hor/iso)' )   
     171      ioptio = 0   
     172      IF( ln_dynldf_bilap_level )   ioptio = ioptio + 1   
     173      IF( ln_dynldf_bilap_hor   )   ioptio = ioptio + 1   
     174      IF( ln_dynldf_bilap_iso   )   ioptio = ioptio + 1   
     175      IF( ( ioptio /= 1 ) .and. ln_dynldf_bilap )     &   
     176                        CALL ctl_stop( '          use only ONE direction for bilaplacien mixing (level/hor/iso)' )   
    154177      !                                   ! Set nldf, the type of lateral diffusion, from ln_dynldf_... logicals 
    155178      ierr = 0 
    156179      IF ( ln_dynldf_lap ) THEN      ! laplacian operator 
    157180         IF ( ln_zco ) THEN                ! z-coordinate 
    158             IF ( ln_dynldf_level )   nldf = 0      ! iso-level  (no rotation) 
    159             IF ( ln_dynldf_hor   )   nldf = 0      ! horizontal (no rotation) 
    160             IF ( ln_dynldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
     181            IF ( ln_dynldf_lap_level )   nldf = 0      ! iso-level  (no rotation) 
     182            IF ( ln_dynldf_lap_hor   )   nldf = 0      ! horizontal (no rotation) 
     183            IF ( ln_dynldf_lap_iso   )   nldf = 1      ! isoneutral (   rotation) 
    161184         ENDIF 
    162185         IF ( ln_zps ) THEN             ! z-coordinate 
    163             IF ( ln_dynldf_level )   ierr = 1      ! iso-level not allowed 
    164             IF ( ln_dynldf_hor   )   nldf = 0      ! horizontal (no rotation) 
    165             IF ( ln_dynldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
    166          ENDIF 
    167          IF ( ln_sco ) THEN             ! s-coordinate 
    168             IF ( ln_dynldf_level )   nldf = 0      ! iso-level  (no rotation) 
    169             IF ( ln_dynldf_hor   )   nldf = 1      ! horizontal (   rotation) 
    170             IF ( ln_dynldf_iso   )   nldf = 1      ! isoneutral (   rotation) 
     186            IF ( ln_dynldf_lap_level )   ierr = 1      ! iso-level not allowed   
     187            IF ( ln_dynldf_lap_hor   )   nldf = 0      ! horizontal (no rotation)   
     188            IF ( ln_dynldf_lap_iso   )   nldf = 1      ! isoneutral (   rotation)   
     189         ENDIF   
     190         IF ( ln_sco ) THEN             ! s-coordinate   
     191            IF ( ln_dynldf_lap_level )   nldf = 0      ! iso-level  (no rotation)   
     192            IF ( ln_dynldf_lap_hor   )   nldf = 1      ! horizontal (   rotation)   
     193            IF ( ln_dynldf_lap_iso   )   nldf = 1      ! isoneutral (   rotation)   
    171194         ENDIF 
    172195      ENDIF 
    … …  
    174197      IF( ln_dynldf_bilap ) THEN      ! bilaplacian operator 
    175198         IF ( ln_zco ) THEN                ! z-coordinate 
    176             IF ( ln_dynldf_level )   nldf = 2      ! iso-level  (no rotation) 
    177             IF ( ln_dynldf_hor   )   nldf = 2      ! horizontal (no rotation) 
    178             IF ( ln_dynldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
     199            IF ( ln_dynldf_bilap_level )   nldf = 2      ! iso-level  (no rotation) 
     200            IF ( ln_dynldf_bilap_hor   )   nldf = 2      ! horizontal (no rotation) 
     201            IF ( ln_dynldf_bilap_iso   )   ierr = 2      ! isoneutral (   rotation) 
    179202         ENDIF 
    180203         IF ( ln_zps ) THEN             ! z-coordinate 
    181             IF ( ln_dynldf_level )   ierr = 1      ! iso-level not allowed  
    182             IF ( ln_dynldf_hor   )   nldf = 2      ! horizontal (no rotation) 
    183             IF ( ln_dynldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
     204            IF ( ln_dynldf_bilap_level )   ierr = 1      ! iso-level not allowed  
     205            IF ( ln_dynldf_bilap_hor   )   nldf = 2      ! horizontal (no rotation) 
     206            IF ( ln_dynldf_bilap_iso   )   ierr = 2      ! isoneutral (   rotation) 
    184207         ENDIF 
    185208         IF ( ln_sco ) THEN             ! s-coordinate 
    186             IF ( ln_dynldf_level )   nldf = 2      ! iso-level  (no rotation) 
    187             IF ( ln_dynldf_hor   )   nldf = 3      ! horizontal (   rotation) 
    188             IF ( ln_dynldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
     209            IF ( ln_dynldf_bilap_level )   nldf = 2      ! iso-level  (no rotation) 
     210            IF ( ln_dynldf_bilap_hor   )   nldf = 3      ! horizontal (   rotation) 
     211            IF ( ln_dynldf_bilap_iso   )   ierr = 2      ! isoneutral (   rotation) 
    189212         ENDIF 
    190213      ENDIF 
    191214       
    192       IF( ln_dynldf_lap .AND. ln_dynldf_bilap ) THEN  ! mixed laplacian and bilaplacian operators 
    193          IF ( ln_zco ) THEN                ! z-coordinate 
    194             IF ( ln_dynldf_level )   nldf = 4      ! iso-level  (no rotation) 
    195             IF ( ln_dynldf_hor   )   nldf = 4      ! horizontal (no rotation) 
    196             IF ( ln_dynldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    197          ENDIF 
    198          IF ( ln_zps ) THEN             ! z-coordinate 
    199             IF ( ln_dynldf_level )   ierr = 1      ! iso-level not allowed  
    200             IF ( ln_dynldf_hor   )   nldf = 4      ! horizontal (no rotation) 
    201             IF ( ln_dynldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    202          ENDIF 
    203          IF ( ln_sco ) THEN             ! s-coordinate 
    204             IF ( ln_dynldf_level )   nldf = 4      ! iso-level  (no rotation) 
    205             IF ( ln_dynldf_hor   )   nldf = 5      ! horizontal (   rotation) 
    206             IF ( ln_dynldf_iso   )   ierr = 2      ! isoneutral (   rotation) 
    207          ENDIF 
    208       ENDIF 
    209  
     215      IF( ln_dynldf_lap .AND. ln_dynldf_bilap ) THEN  ! mixed laplacian and bilaplacian operators   
     216         IF ( ln_zco ) THEN                ! z-coordinate   
     217            IF ( ln_dynldf_lap_level .or. ln_dynldf_bilap_level )   nldf = 4      !   
     218            IF ( ln_dynldf_lap_hor   .or. ln_dynldf_bilap_hor   )   nldf = 4      !   
     219            IF ( ln_dynldf_lap_iso   .or. ln_dynldf_bilap_iso   )   ierr = 2      ! isoneutral (   rotation)   
     220         ENDIF   
     221         IF ( ln_zps ) THEN             ! z-coordinate   
     222            IF ( ln_dynldf_lap_level .or. ln_dynldf_bilap_level )   ierr = 1      ! iso-level not allowed  
     223            IF ( ln_dynldf_lap_hor   .or. ln_dynldf_bilap_hor   )   nldf = 4      !   
     224            IF ( ln_dynldf_lap_iso   .or. ln_dynldf_bilap_iso   )   ierr = 2      !   
     225         ENDIF   
     226         IF ( ln_sco ) THEN             ! s-coordinate   
     227            IF ( ln_dynldf_lap_level .or. ln_dynldf_bilap_level )   nldf = 4      !   
     228            IF ( ln_dynldf_lap_hor   .or. ln_dynldf_bilap_hor   )   nldf = 4      !   
     229            IF ( ln_dynldf_lap_iso   .or. ln_dynldf_bilap_iso   )   ierr = 2      !   
     230         ENDIF   
     231      ENDIF   
     232      ! 
    210233      IF( lk_esopa )                 nldf = -1     ! esopa test 
    211234 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90

    r7363 r7367  
    193193      ! 
    194194      REAL(wp), POINTER, DIMENSION(:,:) :: ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v 
     195      ! 
     196      REAL(wp), POINTER, DIMENSION(:,:,:) ::   uslp, wslpi          !: i_slope at U- and W-points  
     197      REAL(wp), POINTER, DIMENSION(:,:,:) ::   vslp, wslpj          !: j-slope at V- and W-points  
    195198      !!---------------------------------------------------------------------- 
    196199      ! 
    … …  
    198201      ! 
    199202      CALL wrk_alloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v )  
    200       ! 
     203      CALL wrk_alloc( jpi, jpj, jpk, uslp, wslpi, vslp, wslpj )  
     204      ! 
     205      IF ( ln_dynldf_bilap_iso ) THEN   
     206         uslp  = uslp_iso   
     207         vslp  = vslp_iso   
     208         wslpi = wslpi_iso   
     209         wslpj = wslpj_iso   
     210      ELSEIF ( ln_dynldf_bilap_hor ) THEN   
     211         uslp  = uslp_hor   
     212         vslp  = vslp_hor   
     213         wslpi = wslpi_hor   
     214         wslpj = wslpj_hor   
     215      ENDIF   
    201216      !                               ! ********** !   ! =============== 
    202217      DO jk = 1, jpkm1                ! First step !   ! Horizontal slab 
    … …  
    455470 
    456471      CALL wrk_dealloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v )  
     472      CALL wrk_dealloc( jpi, jpj, jpk, uslp, wslpi, vslp, wslpj )  
    457473      ! 
    458474      IF( nn_timing == 1 )  CALL timing_stop('ldfguv') 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_iso.F90

    r7363 r7367  
    3131   USE wrk_nemo        ! Memory Allocation 
    3232   USE timing          ! Timing 
     33#if defined key_bdy   
     34   USE bdy_oce         ! needed for extra diffusion in rim   
     35#endif 
    3336 
    3437   IMPLICIT NONE 
    … …  
    116119      REAL(wp) ::   zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj   !   -      - 
    117120      ! 
     121      REAL(wp), DIMENSION(jpi,jpj) :: zfactor  ! multiplier for diffusion 
     122      ! 
    118123      REAL(wp), POINTER, DIMENSION(:,:) :: ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v 
     124      REAL(wp), POINTER, DIMENSION(:,:,:) :: uslp, vslp, wslpi, wslpj 
    119125      !!---------------------------------------------------------------------- 
    120126      ! 
    … …  
    122128      ! 
    123129      CALL wrk_alloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v )  
     130      CALL wrk_alloc( jpi, jpj, jpk, uslp, vslp, wslpi, wslpj ) 
    124131      ! 
    125132      IF( kt == nit000 ) THEN 
    … …  
    131138      ENDIF 
    132139 
    133       ! s-coordinate: Iso-level diffusion on momentum but not on tracer 
    134       IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 
    135          ! 
    136          DO jk = 1, jpk         ! set the slopes of iso-level 
    137             DO jj = 2, jpjm1 
    138                DO ji = fs_2, fs_jpim1   ! vector opt. 
    139                   uslp (ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept(ji+1,jj,jk) - fsdept(ji ,jj ,jk) ) * umask(ji,jj,jk) 
    140                   vslp (ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept(ji,jj+1,jk) - fsdept(ji ,jj ,jk) ) * vmask(ji,jj,jk) 
    141                   wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw(ji+1,jj,jk) - fsdepw(ji-1,jj,jk) ) * tmask(ji,jj,jk) * 0.5 
    142                   wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw(ji,jj+1,jk) - fsdepw(ji,jj-1,jk) ) * tmask(ji,jj,jk) * 0.5 
    143                END DO 
    144             END DO 
    145          END DO 
    146          ! Lateral boundary conditions on the slopes 
    147          CALL lbc_lnk( uslp , 'U', -1. )      ;      CALL lbc_lnk( vslp , 'V', -1. ) 
    148          CALL lbc_lnk( wslpi, 'W', -1. )      ;      CALL lbc_lnk( wslpj, 'W', -1. ) 
    149   
    150 !!bug 
    151          IF( kt == nit000 ) then 
    152             IF(lwp) WRITE(numout,*) ' max slop: u', SQRT( MAXVAL(uslp*uslp)), ' v ', SQRT(MAXVAL(vslp)),  & 
    153                &                             ' wi', sqrt(MAXVAL(wslpi))     , ' wj', sqrt(MAXVAL(wslpj)) 
    154          endif 
    155 !!end 
    156       ENDIF 
    157  
     140      IF ( ln_dynldf_lap_iso ) THEN   
     141         uslp  = uslp_iso   
     142         vslp  = vslp_iso   
     143         wslpi = wslpi_iso   
     144         wslpj = wslpj_iso   
     145      ELSEIF ( ln_dynldf_lap_hor ) THEN   
     146         uslp  = uslp_hor   
     147         vslp  = vslp_hor   
     148         wslpi = wslpi_hor   
     149         wslpj = wslpj_hor   
     150      ENDIF   
     151      ! 
     152#if defined key_bdy  
     153      zfactor(:,:) = sponge_factor(:,:)  
     154#else  
     155      zfactor(:,:) = 1.0  
     156#endif  
    158157      !                                                ! =============== 
    159158      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    200199            DO jj = 2, jpjm1 
    201200               DO ji = fs_2, jpi   ! vector opt. 
    202                   zabe1 = (fsahmt(ji,jj,jk)+ahmb0) * e2t(ji,jj) * fse3t(ji,jj,jk) / e1t(ji,jj) 
     201                  zabe1 = zfactor(ji,jj) * (fsahmt(ji,jj,jk)+ahmb0) * e2t(ji,jj) * fse3t(ji,jj,jk) / e1t(ji,jj) 
    203202 
    204203                  zmskt = 1./MAX(  umask(ji-1,jj,jk  )+umask(ji,jj,jk+1)   & 
    205204                     &           + umask(ji-1,jj,jk+1)+umask(ji,jj,jk  ), 1. ) 
    206205 
    207                   zcof1 = - aht0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) 
     206                  zcof1 = - zfactor(ji,jj) * aht0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) 
    208207 
    209208                  ziut(ji,jj) = (  zabe1 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) )   & 
    … …  
    217216         DO jj = 1, jpjm1 
    218217            DO ji = 1, fs_jpim1   ! vector opt. 
    219                zabe2 = ( fsahmf(ji,jj,jk) + ahmb0 ) * e1f(ji,jj) * fse3f(ji,jj,jk) / e2f(ji,jj) 
     218               zabe2 = zfactor(ji,jj) * ( fsahmf(ji,jj,jk) + ahmb0 ) * e1f(ji,jj) * fse3f(ji,jj,jk) / e2f(ji,jj) 
    220219 
    221220               zmskf = 1./MAX(  umask(ji,jj+1,jk  )+umask(ji,jj,jk+1)   & 
    222221                  &           + umask(ji,jj+1,jk+1)+umask(ji,jj,jk  ), 1. ) 
    223222 
    224                zcof2 = - aht0 * e1f(ji,jj) * zmskf * 0.5  * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) ) 
     223               zcof2 = - zfactor(ji,jj) * aht0 * e1f(ji,jj) * zmskf * 0.5  * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) ) 
    225224 
    226225               zjuf(ji,jj) = (  zabe2 * ( ub(ji,jj+1,jk) - ub(ji,jj,jk) )   & 
    … …  
    238237         DO jj = 2, jpjm1 
    239238            DO ji = 1, fs_jpim1   ! vector opt. 
    240                zabe1 = ( fsahmf(ji,jj,jk) + ahmb0 ) * e2f(ji,jj) * fse3f(ji,jj,jk) / e1f(ji,jj) 
     239               zabe1 = zfactor(ji,jj) * ( fsahmf(ji,jj,jk) + ahmb0 ) * e2f(ji,jj) * fse3f(ji,jj,jk) / e1f(ji,jj) 
    241240 
    242241               zmskf = 1./MAX(  vmask(ji+1,jj,jk  )+vmask(ji,jj,jk+1)   & 
    243242                  &           + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk  ), 1. ) 
    244243 
    245                zcof1 = - aht0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) ) 
     244               zcof1 = - zfactor(ji,jj) * aht0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) ) 
    246245 
    247246               zivf(ji,jj) = (  zabe1 * ( vb(ji+1,jj,jk) - vb(ji,jj,jk) )   & 
    … …  
    270269            DO jj = 2, jpj 
    271270               DO ji = 1, fs_jpim1   ! vector opt. 
    272                   zabe2 = (fsahmt(ji,jj,jk)+ahmb0) * e1t(ji,jj) * fse3t(ji,jj,jk) / e2t(ji,jj) 
     271                  zabe2 = zfactor(ji,jj) * (fsahmt(ji,jj,jk)+ahmb0) * e1t(ji,jj) * fse3t(ji,jj,jk) / e2t(ji,jj) 
    273272 
    274273                  zmskt = 1./MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)   & 
    275274                     &           + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ), 1. ) 
    276275 
    277                   zcof2 = - aht0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) 
     276                  zcof2 = - zfactor(ji,jj) * aht0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) 
    278277 
    279278                  zjvt(ji,jj) = (  zabe2 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) )   & 
    … …  
    428427      !                                                ! =============== 
    429428      CALL wrk_dealloc( jpi, jpj, ziut, zjuf, zjvt, zivf, zdku, zdk1u, zdkv, zdk1v )  
     429      CALL wrk_dealloc( jpi, jpj, jpk, uslp, vslp, wslpi, wslpj )  
    430430      ! 
    431431      IF( nn_timing == 1 )  CALL timing_stop('dyn_ldf_iso') 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r7363 r7367  
    215215            !                             ! ================! 
    216216            ! 
    217             DO jk = 1, jpkm1                 ! Before scale factor at t-points 
    218                fse3t_b(:,:,jk) = fse3t_n(:,:,jk)                                   & 
    219                   &              + atfp * (  fse3t_b(:,:,jk) + fse3t_a(:,:,jk)     & 
    220                   &                         - 2._wp * fse3t_n(:,:,jk)            ) 
    221             END DO 
     217!jth            DO jk = 1, jpkm1                 ! Before scale factor at t-points 
     218!jth               fse3t_b(:,:,jk) = fse3t_n(:,:,jk)                                   & 
     219!jth                  &              + atfp * (  fse3t_b(:,:,jk) + fse3t_a(:,:,jk)     & 
     220!jth                  &                         - 2._wp * fse3t_n(:,:,jk)            ) 
     221!jth            END DO 
    222222            zec = atfp * rdt / rau0          ! Add filter correction only at the 1st level of t-point scale factors 
    223             fse3t_b(:,:,1) = fse3t_b(:,:,1) - zec * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
     223!jth            fse3t_b(:,:,1) = fse3t_b(:,:,1) - zec * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
    224224            ! 
    225225            IF( ln_dynadv_vec ) THEN         ! vector invariant form (no thickness weighted calulation) 
    226226               ! 
    227227               !                                      ! before scale factors at u- & v-pts (computed from fse3t_b) 
    228                CALL dom_vvl_2( kt, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
     228!jth              CALL dom_vvl_2( kt, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 
    229229               ! 
    230230               DO jk = 1, jpkm1                       ! Leap-Frog - Asselin filter and swap: applied on velocity 
    … …  
    244244            ELSE                             ! flux form (thickness weighted calulation) 
    245245               ! 
    246                CALL dom_vvl_2( kt, ze3u_f, ze3v_f )   ! before scale factors at u- & v-pts (computed from fse3t_b) 
     246!jth               CALL dom_vvl_2( kt, ze3u_f, ze3v_f )   ! before scale factors at u- & v-pts (computed from fse3t_b) 
    247247               ! 
    248248               DO jk = 1, jpkm1                       ! Leap-Frog - Asselin filter and swap:  
    … …  
    266266                  END DO 
    267267               END DO 
    268                fse3u_b(:,:,1:jpkm1) = ze3u_f(:,:,1:jpkm1)      ! e3u_b <-- filtered scale factor 
    269                fse3v_b(:,:,1:jpkm1) = ze3v_f(:,:,1:jpkm1) 
     268!jth               fse3u_b(:,:,1:jpkm1) = ze3u_f(:,:,1:jpkm1)      ! e3u_b <-- filtered scale factor 
     269!jth               fse3v_b(:,:,1:jpkm1) = ze3v_f(:,:,1:jpkm1) 
    270270               CALL lbc_lnk( ub, 'U', -1. )                    ! lateral boundary conditions 
    271271               CALL lbc_lnk( vb, 'V', -1. ) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r7363 r7367  
    106106                  &                   + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) /e1u(ji,jj) 
    107107               spgv(ji,jj) =  zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    & 
    108                   &                   + ssh_ibb(ji,jj+1) - ssh_ib (ji,jj)  ) /e2v(ji,jj) 
     108                  &                   + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) /e2v(ji,jj) 
    109109            END DO 
    110110         END DO 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r7363 r7367  
    299299              ikbu = mbku(ji,jj) 
    300300              ikbv = mbkv(ji,jj) 
    301               ua_btm = zcu(ji,jj) * z2dt_bf * hur(ji,jj) * umask (ji,jj,ikbu) 
    302               va_btm = zcv(ji,jj) * z2dt_bf * hvr(ji,jj) * vmask (ji,jj,ikbv) 
     301!jth              ua_btm = zcu(ji,jj) * z2dt_bf * hur(ji,jj) * umask (ji,jj,ikbu) 
     302!jth              va_btm = zcv(ji,jj) * z2dt_bf * hvr(ji,jj) * vmask (ji,jj,ikbv) 
     303              ua_btm =  (ub_b(ji,jj) +zua(ji,jj)*z2dt_bf)* hur(ji,jj) * umask (ji,jj,ikbu) 
     304              va_btm =  (vb_b(ji,jj) +zva(ji,jj)*z2dt_bf)* hvr(ji,jj) * vmask (ji,jj,ikbv) 
    303305 
    304306              zua(ji,jj) = zua(ji,jj) - bfrua(ji,jj) * ua_btm 
    … …  
    466468                  ! after velocities with implicit bottom friction 
    467469 
    468                   IF( ln_bfrimp ) THEN      ! implicit bottom friction 
    469                      !   A new method to implement the implicit bottom friction.  
    470                      !   H. Liu 
    471                      !   Sept 2011 
    472                      ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
    473                       &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
    474                       &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
    475                      ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
    476                      ! 
    477                      va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
    478                       &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
    479                       &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
    480                      va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
    481                      ! 
    482                   ELSE 
     470!jth                  IF( ln_bfrimp ) THEN      ! implicit bottom friction 
     471!                     !   A new method to implement the implicit bottom friction.  
     472!                     !   H. Liu 
     473!                     !   Sept 2011 
     474!                     ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
     475!                      &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
     476!                      &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
     477!                     ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
     478!                     ! 
     479!                     va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
     480!                      &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
     481!                      &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
     482!                     va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
     483!                     ! 
     484!                  ELSE 
    483485                     ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1)   & 
    484486                      &           / ( 1._wp         - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 
    485487                     va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1)   & 
    486488                      &           / ( 1._wp         - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 
    487                   ENDIF 
     489!                  ENDIF 
    488490               END DO 
    489491            END DO 
    … …  
    513515                  zv_cor  = zx1 * ( ff(ji-1,jj  ) + ff(ji,jj) ) * hvr_e(ji,jj) 
    514516                  ! after velocities with implicit bottom friction 
    515                   IF( ln_bfrimp ) THEN 
    516                      !   A new method to implement the implicit bottom friction.  
    517                      !   H. Liu 
    518                      !   Sept 2011 
    519                      ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
    520                       &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
    521                       &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
    522                      ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
    523                      ! 
    524                      va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
    525                       &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
    526                       &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
    527                      va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
    528                      ! 
    529                   ELSE 
     517!                  IF( ln_bfrimp ) THEN 
     518!                     !   A new method to implement the implicit bottom friction.  
     519!                     !   H. Liu 
     520!                     !   Sept 2011 
     521!                     ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
     522!                      &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
     523!                      &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
     524!                     ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
     525!                     ! 
     526!                     va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
     527!                      &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
     528!                      &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
     529!                     va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
     530!                     ! 
     531!                  ELSE 
    530532                     ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1)   & 
    531533                     &            / ( 1._wp        - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 
    532534                     va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1)   & 
    533535                     &            / ( 1._wp        - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 
    534                   ENDIF 
     536!                  ENDIF 
    535537               END DO 
    536538            END DO 
    … …  
    560562                     &                           + ftnw(ji,jj  ) * zwx(ji-1,jj  ) + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) * hvr_e(ji,jj) 
    561563                  ! after velocities with implicit bottom friction 
    562                   IF( ln_bfrimp ) THEN 
    563                      !   A new method to implement the implicit bottom friction.  
    564                      !   H. Liu 
    565                      !   Sept 2011 
    566                      ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
    567                       &                               z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp )            & 
    568                       &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
    569                      ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
    570                      ! 
    571                      va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
    572                       &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
    573                       &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
    574                      va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
    575                      ! 
    576                   ELSE 
     564!                  IF( ln_bfrimp ) THEN 
     565!                     !   A new method to implement the implicit bottom friction.  
     566!                     !   H. Liu 
     567!                     !   Sept 2011 
     568!                     ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) +                                            & 
     569!                      &                               / ( 1._wp      - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 
     570!                     ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e *   zua(ji,jj)  ) * umask(ji,jj,1)    
     571!                     ! 
     572!                     va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) +                                            & 
     573!                      &                               z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp )            & 
     574!                      &                               / ( 1._wp      - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 
     575!                     va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e *   zva(ji,jj)  ) * vmask(ji,jj,1)    
     576!                     ! 
     577!                  ELSE 
    577578                     ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1)   & 
    578579                     &            / ( 1._wp        - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 
    579580                     va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1)   & 
    580581                     &            / ( 1._wp        - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 
    581                   ENDIF 
     582!                 ENDIF 
    582583               END DO 
    583584            END DO 
    … …  
    685686      CALL wrk_dealloc( jpi, jpj, zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum ) 
    686687      ! 
     688      IF ( ln_diatmb ) THEN 
     689         CALL iom_put( "baro_u" , un_b*umask(:,:,1)+missing_val*(1-umask(:,:,1 ) ) )  ! Barotropic  U Velocity 
     690         CALL iom_put( "baro_v" , vn_b*vmask(:,:,1)+missing_val*(1-vmask(:,:,1 ) ) )  ! Barotropic  V Velocity 
     691      ENDIF 
    687692      IF( nn_timing == 1 )  CALL timing_stop('dyn_spg_ts') 
    688693      ! 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf.F90

    r7363 r7367  
    125125      ! Force implicit schemes 
    126126      IF( lk_zdftke .OR. lk_zdfgls .OR. lk_zdfkpp )   nzdf = 1   ! TKE, GLS or KPP physics 
    127       IF( ln_dynldf_iso                           )   nzdf = 1   ! iso-neutral lateral physics 
    128       IF( ln_dynldf_hor .AND. ln_sco              )   nzdf = 1   ! horizontal lateral physics in s-coordinate 
     127      IF(    ( ln_dynldf_lap   .and. ln_dynldf_lap_iso   )   &   
     128        .or. ( ln_dynldf_bilap .and. ln_dynldf_bilap_iso ) )                 nzdf = 1   ! iso-neutral lateral physics   
     129      IF( (  ( ln_dynldf_lap   .and. ln_dynldf_lap_hor   )   &   
     130        .or. ( ln_dynldf_bilap .and. ln_dynldf_bilap_hor ) ) .AND. ln_sco )  nzdf = 1   ! horizontal lateral physics in s-coordinate  
    129131      ! 
    130132      IF( lk_esopa )    nzdf = -1                   ! Esopa key: All schemes used 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r7363 r7367  
    2525   CHARACTER(lc) ::   cn_ocerst_in  = "restart"   !: suffix of ocean restart name (input) 
    2626   CHARACTER(lc) ::   cn_ocerst_out = "restart"   !: suffix of ocean restart name (output) 
     27   CHARACTER(lc) ::   cn_rst_dir    = "./"        !: restart directory  
    2728   LOGICAL       ::   ln_rstart     = .FALSE.     !: start from (F) rest or (T) a restart file 
     29   LOGICAL       ::   ln_rstdate    = .FALSE.     !: Use calendar date rather than time-step in restart names  
    2830   INTEGER       ::   nn_no         = 0           !: job number 
    2931   INTEGER       ::   nn_rstctl     = 0           !: control of the time step (0, 1 or 2) 
    … …  
    3638   INTEGER       ::   nn_write      =   10        !: model standard output frequency 
    3739   INTEGER       ::   nn_stock      =   10        !: restart file frequency 
     40   INTEGER, PARAMETER           :: jpstocks     = 1000 !: maximum number of restarts    
     41   INTEGER, DIMENSION(jpstocks) :: nn_stocklist = 0    !: restart dump times   
    3842   LOGICAL       ::   ln_dimgnnn    = .FALSE.     !: type of dimgout. (F): 1 file for all proc 
    3943                                                       !:                  (T): 1 file per proc 
    4044   LOGICAL       ::   ln_mskland    = .FALSE.     !: mask land points in NetCDF outputs (costly: + ~15%) 
     45   LOGICAL       ::   ln_NOOS       = .FALSE.     !: NOOS transects  diagnostics 
    4146   LOGICAL       ::   ln_clobber    = .FALSE.     !: clobber (overwrite) an existing file 
     47   LOGICAL       ::   ln_diatide    = .FALSE.     !: tide mean diagnostics (25h) 
     48   LOGICAL       ::   ln_diatmb     = .FALSE.     !: tmb diagnostics 
    4249   INTEGER       ::   nn_chunksz    = 0           !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) 
     50 
     51   LOGICAL              ::  ln_diafoam = .FALSE.            !: Met Office FOAM diagnostics  
     52   INTEGER,DIMENSION(7) ::  nn_diafoam = (/0,0,0,0,0,0,0/)  !: Met Office FOAM diagnostic choices  
     53   LOGICAL              ::  ln_depwri  = .FALSE.            !: Met Office depths file for interp  
     54 
    4355#if defined key_netcdf4 
    4456   !!---------------------------------------------------------------------- 
    … …  
    7688   INTEGER       ::   nwrite                      !: model standard output frequency 
    7789   INTEGER       ::   nstock                      !: restart file frequency 
     90   INTEGER, DIMENSION(jpstocks) :: nstock_list    !: restart file list of times 
    7891 
    7992   !!---------------------------------------------------------------------- 
    … …  
    114127   INTEGER ::   numdct_in   =   -1      !: logical unit for transports computing 
    115128   INTEGER ::   numdct_vol  =   -1      !: logical unit for voulume transports output 
    116    INTEGER ::   numdct_heat =   -1      !: logical unit for heat    transports output 
    117    INTEGER ::   numdct_salt =   -1      !: logical unit for salt    transports output 
     129   INTEGER ::   numdct_temp =   -1      !: logical unit for heat    transports output 
     130   INTEGER ::   numdct_sal  =   -1      !: logical unit for salt    transports output 
     131   INTEGER ::   numdct_NOOS =   -1      !: logical unit for NOOS    transports output 
     132   INTEGER ::   numdct_NOOS_h = -1      !: logical unit for NOOS hourly transports output 
    118133   INTEGER ::   numfl      =   -1      !: logical unit for floats ascii output 
    119134   INTEGER ::   numflo     =   -1      !: logical unit for floats ascii output 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r7363 r7367  
    162162      LOGICAL         , INTENT(in   ), OPTIONAL ::   ldiof    ! Interp On the Fly, needed for AGRIF (default = .FALSE.) 
    163163 
    164       CHARACTER(LEN=100)    ::   clname    ! the name of the file based on cdname [[+clcpu]+clcpu] 
    165       CHARACTER(LEN=100)    ::   cltmpn    ! tempory name to store clname (in writting mode) 
     164      CHARACTER(LEN=200)    ::   clname    ! the name of the file based on cdname [[+clcpu]+clcpu] 
     165      CHARACTER(LEN=200)    ::   cltmpn    ! tempory name to store clname (in writting mode) 
    166166      CHARACTER(LEN=10)     ::   clsuffix  ! ".nc" or ".dimg" 
    167167      CHARACTER(LEN=15)     ::   clcpu     ! the cpu number (max jpmax_digits digits) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r7363 r7367  
    6161      INTEGER, DIMENSION(2,5), INTENT(in   ), OPTIONAL ::   kdompar     ! domain parameters:  
    6262 
    63       CHARACTER(LEN=100) ::   clinfo           ! info character 
    64       CHARACTER(LEN=100) ::   cltmp            ! temporary character 
     63      CHARACTER(LEN=200) ::   clinfo           ! info character 
     64      CHARACTER(LEN=200) ::   cltmp            ! temporary character 
    6565      INTEGER            ::   iln              ! lengths of character 
    6666      INTEGER            ::   istop            ! temporary storage of nstop 
    … …  
    389389      INTEGER, DIMENSION(4) :: idimsz               ! dimensions size   
    390390      INTEGER, DIMENSION(4) :: idimid               ! dimensions id 
    391       CHARACTER(LEN=100)    :: clinfo               ! info character 
     391      CHARACTER(LEN=200)    :: clinfo               ! info character 
    392392      CHARACTER(LEN= 12), DIMENSION(4) :: cltmp     ! temporary character 
    393393      INTEGER               :: if90id               ! nf90 file identifier 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90

    r7363 r7367  
    118118      IF( PRESENT(tab2d_1) )   ztab2d_1(:,:)        = tab2d_1(:,:) 
    119119      IF( PRESENT(tab2d_2) )   ztab2d_2(:,:)        = tab2d_2(:,:) 
    120       IF( PRESENT(tab3d_1) )   ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,:) 
    121       IF( PRESENT(tab3d_2) )   ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,:) 
     120      IF( PRESENT(tab3d_1) )   ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir) 
     121      IF( PRESENT(tab3d_2) )   ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir) 
    122122      IF( PRESENT(mask1)   )   zmask1  (:,:,:)      = mask1  (:,:,:) 
    123123      IF( PRESENT(mask2)   )   zmask2  (:,:,:)      = mask2  (:,:,:) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r7363 r7367  
    2121   USE in_out_manager  ! I/O manager 
    2222   USE iom             ! I/O module 
     23   USE ioipsl, ONLY : ju2ymds    ! for calendar 
    2324   USE eosbn2          ! equation of state            (eos bn2 routine) 
    2425   USE trdmld_oce      ! ocean active mixed layer tracers trends variables 
    … …  
    3435   LOGICAL, PUBLIC ::   lrst_oce =  .FALSE.   !: logical to control the oce restart write  
    3536   INTEGER, PUBLIC ::   numror, numrow        !: logical unit for cean restart (read and write) 
     37   INTEGER, PUBLIC ::   nrst                  !: index of next restart dump 
    3638 
    3739   !! * Substitutions 
    … …  
    5658      !!---------------------------------------------------------------------- 
    5759      INTEGER, INTENT(in) ::   kt     ! ocean time-step 
     60      INTEGER             ::   iyear, imonth, iday 
     61      REAL (wp)           ::   zsec 
    5862      !! 
     63      CHARACTER(len=150)  ::   clpath   ! full path to ocean output restart file 
    5964      CHARACTER(LEN=20)   ::   clkt     ! ocean time-step deine as a character 
    6065      CHARACTER(LEN=50)   ::   clname   ! ice output restart file name 
    61       !!---------------------------------------------------------------------- 
    62       ! 
    63       IF( kt == nit000 ) THEN   ! default definitions 
    64          lrst_oce = .FALSE.    
    65          nitrst = nitend 
    66       ENDIF 
    67       IF( MOD( kt - 1, nstock ) == 0 ) THEN    
    68          ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment 
    69          nitrst = kt + nstock - 1                  ! define the next value of nitrst for restart writing 
    70          IF( nitrst > nitend )   nitrst = nitend   ! make sure we write a restart at the end of the run 
     66      CHARACTER(LEN=10)   ::   cltimes  ! restart dump times needed   
     67      INTEGER :: it   
     68      !!---------------------------------------------------------------------- 
     69      ! 
     70      IF( kt == nit000 ) THEN   
     71         IF ( ALL( nstock_list == 0 ) ) THEN   
     72            ! Dumps to be written every nstock steps and at nitend   
     73            nstock_list = nstock * (/ (it, it = 1, jpstocks) /)  +  nit000 - 1   
     74            nstock_list = MIN( nstock_list, nitend )   
     75            IF ( MAXVAL(nstock_list) < nitend ) THEN   
     76               WRITE(cltimes,FMT='(i10)') (nitend - nit000 + 1)/nstock + 1   
     77               CALL ctl_stop( 'rst_opn:', &   
     78                 'Too many restart dump times to store in the array', &   
     79                 'Increase jpstocks to ' // cltimes  )   
     80            END IF   
     81         END IF   
     82         nrst = 1   
     83         nitrst = nstock_list( nrst )   
     84         lrst_oce = .FALSE.   
    7185      ENDIF 
    7286      ! to get better performances with NetCDF format: 
    … …  
    7589      IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 
    7690         ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
    77          IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 
    78          ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst 
     91         IF ( ln_rstdate ) THEN 
     92            CALL ju2ymds( fjulday + rdttra(1) / rday, iyear, imonth, iday, zsec )            
     93            WRITE(clkt, '(i4.4,2i2.2)') iyear, imonth, iday 
     94         ELSE 
     95            IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 
     96            ELSE                            ;   WRITE(clkt, '(i8.8)') nitrst 
     97            ENDIF 
    7998         ENDIF 
    8099         ! create the file 
    81100         clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_"//TRIM(cn_ocerst_out) 
     101         clpath = TRIM(cn_rst_dir) 
     102         IF( clpath(LEN_TRIM(clpath):) /= '/' ) then 
     103           clpath = TRIM(clpath) // '/' 
     104         ENDIF 
    82105         IF(lwp) THEN 
    83106            WRITE(numout,*) 
    84107            SELECT CASE ( jprstlib ) 
    85             CASE ( jprstdimg )   ;   WRITE(numout,*) '             open ocean restart binary file: '//clname 
    86             CASE DEFAULT         ;   WRITE(numout,*) '             open ocean restart NetCDF file: '//clname 
     108            CASE ( jprstdimg )   ;   WRITE(numout,*)                            & 
     109                '             open ocean restart binary file: ',TRIM(clpath)//clname 
     110            CASE DEFAULT         ;   WRITE(numout,*)                            & 
     111                '             open ocean restart NetCDF file: ',TRIM(clpath)//clname 
    87112            END SELECT 
    88113            IF ( snc4set%luse )      WRITE(numout,*) '             opened for NetCDF4 chunking and compression' 
    … …  
    92117         ENDIF 
    93118         ! 
    94          CALL iom_open( clname, numrow, ldwrt = .TRUE., kiolib = jprstlib ) 
     119         CALL iom_open( TRIM(clpath)//TRIM(clname), numrow, ldwrt = .TRUE., kiolib = jprstlib ) 
    95120         lrst_oce = .TRUE. 
    96121      ENDIF 
    … …  
    121146                     CALL iom_rstput( kt, nitrst, numrow, 'hdivb'  , hdivb     ) 
    122147                     CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , sshb      ) 
    123       IF( lk_vvl )   CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
     148!jth      IF( lk_vvl )   CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 
    124149                     ! 
    125150                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , un        )     ! now fields 
    … …  
    131156                     CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , sshn      ) 
    132157                     CALL iom_rstput( kt, nitrst, numrow, 'rhop'   , rhop      ) 
     158                     CALL iom_rstput( kt, nitrst, numrow, 'zenv'   , zenv      ) 
    133159#if defined key_zdfkpp 
    134160                     CALL iom_rstput( kt, nitrst, numrow, 'rhd'    , rhd       ) 
    135161#endif 
    136162      IF( kt == nitrst ) THEN 
    137          CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    138          IF( .NOT. lk_trdmld )   lrst_oce = .FALSE. 
     163         CALL iom_close( numrow )     ! close the restart file (only on the dump time step)   
     164         IF( .NOT. lk_trdmld ) THEN   
     165             lrst_oce = .FALSE.   
     166             nrst = nrst + 1   
     167             nitrst = nstock_list( nrst )   
     168         END IF   
    139169      ENDIF 
    140170      ! 
    … …  
    190220                     CALL iom_get( numror, jpdom_autoglo, 'hdivb'  , hdivb   ) 
    191221                     CALL iom_get( numror, jpdom_autoglo, 'sshb'   , sshb    ) 
    192       IF( lk_vvl )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
     222!jth      IF( lk_vvl )   CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 
    193223                     ! 
    194224                     CALL iom_get( numror, jpdom_autoglo, 'un'     , un      )   ! now    fields 
    … …  
    215245         hdivb(:,:,:)   = hdivn(:,:,:) 
    216246         sshb (:,:)     = sshn (:,:) 
    217          IF( lk_vvl ) THEN 
    218             DO jk = 1, jpk 
    219                fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
    220             END DO 
    221          ENDIF 
     247!jth         IF( lk_vvl ) THEN 
     248!            DO jk = 1, jpk 
     249!               fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
     250!            END DO 
     251!         ENDIF 
    222252      ENDIF 
    223253      ! 
    224254   END SUBROUTINE rst_read 
     255 
    225256 
    226257   !!===================================================================== 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r7363 r7367  
    8080   END INTERFACE 
    8181   INTERFACE mpp_sum 
    82 # if defined key_mpp_rep 
    8382      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 
    8483                       mppsum_realdd, mppsum_a_realdd 
    85 # else 
    86       MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real 
    87 # endif 
    8884   END INTERFACE 
    8985   INTERFACE mpp_lbc_north 
    … …  
    114110!$AGRIF_END_DO_NOT_TREAT 
    115111 
    116 # if defined key_mpp_rep 
    117112   INTEGER :: MPI_SUMDD 
    118 # endif 
    119113 
    120114   ! variables used in case of sea-ice 
    121    INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice 
     115   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd) 
     116   INTEGER ::   ngrp_iworld     !  group ID for the world processors (for rheology) 
    122117   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology) 
    123118   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors 
    … …  
    355350      mynode = mpprank 
    356351      !  
    357 #if defined key_mpp_rep 
    358352      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    359 #endif 
    360353      ! 
    361354   END FUNCTION mynode 
    … …  
    15061499   END SUBROUTINE mppsum_real 
    15071500 
    1508 # if defined key_mpp_rep 
    15091501   SUBROUTINE mppsum_realdd( ytab, kcom ) 
    15101502      !!---------------------------------------------------------------------- 
    … …  
    15591551 
    15601552   END SUBROUTINE mppsum_a_realdd 
    1561 # endif    
    15621553    
    15631554   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 
    … …  
    19771968      !!      ndim_rank_ice = number of processors with ice 
    19781969      !!      nrank_ice (ndim_rank_ice) = ice processors 
    1979       !!      ngrp_world = group ID for the world processors 
     1970      !!      ngrp_iworld = group ID for the world processors 
    19801971      !!      ngrp_ice = group ID for the ice processors 
    19811972      !!      ncomm_ice = communicator for the ice procs. 
    … …  
    20262017 
    20272018      ! Create the world group 
    2028       CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr ) 
     2019      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr ) 
    20292020 
    20302021      ! Create the ice group from the world group 
    2031       CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr ) 
     2022      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr ) 
    20322023 
    20332024      ! Create the ice communicator , ie the pool of procs with sea-ice 
    … …  
    20362027      ! Find proc number in the world of proc 0 in the north 
    20372028      ! The following line seems to be useless, we just comment & keep it as reminder 
    2038       ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 
    2039       ! 
     2029      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr) 
     2030      ! 
     2031      CALL MPI_GROUP_FREE(ngrp_ice, ierr) 
     2032      CALL MPI_GROUP_FREE(ngrp_iworld, ierr) 
     2033 
    20402034      DEALLOCATE(kice, zwork) 
    20412035      ! 
    … …  
    25992593   END SUBROUTINE mpi_init_opa 
    26002594 
    2601 #if defined key_mpp_rep 
    26022595   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
    26032596      !!--------------------------------------------------------------------- 
    … …  
    26282621 
    26292622   END SUBROUTINE DDPDD_MPI 
    2630 #endif 
    26312623 
    26322624#else 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn.F90

    r7363 r7367  
    6666      !!  
    6767      NAMELIST/namdyn_ldf/ ln_dynldf_lap  , ln_dynldf_bilap,                  & 
    68          &                 ln_dynldf_level, ln_dynldf_hor  , ln_dynldf_iso,   & 
     68         &                 ln_dynldf_lap_level, ln_dynldf_lap_hor  , ln_dynldf_lap_iso,   & 
     69         &                 ln_dynldf_bilap_level, ln_dynldf_bilap_hor  , ln_dynldf_bilap_iso,   & 
    6970         &                 rn_ahm_0_lap   , rn_ahmb_0      , rn_ahm_0_blp 
    7071      !!---------------------------------------------------------------------- 
    … …  
    8081         WRITE(numout,*) '      laplacian operator                      ln_dynldf_lap   = ', ln_dynldf_lap 
    8182         WRITE(numout,*) '      bilaplacian operator                    ln_dynldf_bilap = ', ln_dynldf_bilap 
    82          WRITE(numout,*) '      iso-level                               ln_dynldf_level = ', ln_dynldf_level 
    83          WRITE(numout,*) '      horizontal (geopotential)               ln_dynldf_hor   = ', ln_dynldf_hor 
    84          WRITE(numout,*) '      iso-neutral                             ln_dynldf_iso   = ', ln_dynldf_iso 
     83         WRITE(numout,*) '      laplacien iso-level                     ln_dynldf_lap_level = ', ln_dynldf_lap_level 
     84         WRITE(numout,*) '      laplacien horizontal (geopotential)     ln_dynldf_lap_hor   = ', ln_dynldf_lap_hor 
     85         WRITE(numout,*) '      laplacien iso-neutral                   ln_dynldf_lap_iso   = ', ln_dynldf_lap_iso 
     86         WRITE(numout,*) '      bilaplacien iso-level                   ln_dynldf_bilap_level = ', ln_dynldf_bilap_level 
     87         WRITE(numout,*) '      bilaplacien horizontal (geopotential)   ln_dynldf_bilap_hor   = ', ln_dynldf_bilap_hor 
     88         WRITE(numout,*) '      bilaplacien iso-neutral                 ln_dynldf_bilap_iso   = ', ln_dynldf_bilap_iso 
    8589         WRITE(numout,*) '      horizontal laplacian eddy viscosity     rn_ahm_0_lap    = ', rn_ahm_0_lap 
    8690         WRITE(numout,*) '      background viscosity                    rn_ahmb_0       = ', rn_ahmb_0 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90

    r7363 r7367  
    6464         END DO 
    6565 
    66          IF( ln_dynldf_iso ) THEN 
     66         IF( (ln_dynldf_lap_iso .and. ln_dynldf_lap) .or. (ln_dynldf_bilap_iso .and. ln_dynldf_bilap) ) THEN   
    6767            IF(lwp) WRITE(numout,*) '              Caution, as implemented now, the isopycnal part of momentum' 
    6868            IF(lwp) WRITE(numout,*) '                 mixing use aht0 as eddy viscosity coefficient. Thus, it is' 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90

    r7363 r7367  
    5959         za00 = ahm0 / zd_max 
    6060 
    61          IF( ln_dynldf_iso ) THEN 
     61         IF( (ln_dynldf_lap_iso .and. ln_dynldf_lap) .or. (ln_dynldf_bilap_iso .and. ln_dynldf_bilap) ) THEN   
    6262            IF(lwp) WRITE(numout,*) '              Caution, as implemented now, the isopycnal part of momentum' 
    6363            IF(lwp) WRITE(numout,*) '                 mixing use aht0 as eddy viscosity coefficient. Thus, it is' 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_oce.F90

    r7363 r7367  
    1616   LOGICAL , PUBLIC ::   ln_dynldf_lap   = .TRUE.      !: laplacian operator 
    1717   LOGICAL , PUBLIC ::   ln_dynldf_bilap = .FALSE.     !: bilaplacian operator 
    18    LOGICAL , PUBLIC ::   ln_dynldf_level = .FALSE.     !: iso-level direction 
    19    LOGICAL , PUBLIC ::   ln_dynldf_hor   = .TRUE.      !: horizontal (geopotential) direction 
    20    LOGICAL , PUBLIC ::   ln_dynldf_iso   = .FALSE.     !: iso-neutral direction 
     18   LOGICAL , PUBLIC ::   ln_dynldf_lap_level = .FALSE.     !: iso-level direction 
     19   LOGICAL , PUBLIC ::   ln_dynldf_lap_hor   = .TRUE.      !: horizontal (geopotential) direction 
     20   LOGICAL , PUBLIC ::   ln_dynldf_lap_iso   = .FALSE.     !: iso-neutral direction 
     21   LOGICAL , PUBLIC ::   ln_dynldf_bilap_level = .FALSE.     !: iso-level direction 
     22   LOGICAL , PUBLIC ::   ln_dynldf_bilap_hor   = .TRUE.      !: horizontal (geopotential) direction 
     23   LOGICAL , PUBLIC ::   ln_dynldf_bilap_iso   = .FALSE.     !: iso-neutral direction 
    2124   REAL(wp), PUBLIC ::   rn_ahm_0_lap    = 40000._wp   !: lateral laplacian eddy viscosity (m2/s) 
    2225   REAL(wp), PUBLIC ::   rn_ahmb_0       =     0._wp   !: lateral laplacian background eddy viscosity (m2/s) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r7363 r7367  
    6060      REAL(wp) ::   zfw, ze3w, zn2, zf20, zaht, zaht_min      ! temporary scalars 
    6161      REAL(wp), DIMENSION(:,:), POINTER ::   zn, zah, zhw, zross   ! 2D workspace 
     62      REAL(wp), DIMENSION(:,:,:), POINTER ::   uslp, vslp, wslpi, wslpj ! 3D workspace 
    6263      !!---------------------------------------------------------------------- 
    6364      ! 
    … …  
    6566      ! 
    6667      CALL wrk_alloc( jpi,jpj, zn, zah, zhw, zross ) 
     68      CALL wrk_alloc( jpi,jpj,jpk, uslp, vslp, wslpi, wslpj ) 
     69  
     70      IF ( ln_traldf_iso ) THEN   
     71         uslp  = uslp_iso   
     72         vslp  = vslp_iso   
     73         wslpi = wslpi_iso   
     74         wslpj = wslpj_iso   
     75      ELSEIF ( ln_traldf_hor ) THEN   
     76         uslp  = uslp_hor   
     77         vslp  = vslp_hor   
     78         wslpi = wslpi_hor   
     79         wslpj = wslpj_hor   
     80      ENDIF   
    6781 
    6882      IF( kt == nit000 ) THEN 
    … …  
    243257      !   
    244258      CALL wrk_dealloc( jpi,jpj, zn, zah, zhw, zross ) 
     259      CALL wrk_dealloc( jpi,jpj,jpk,  uslp, vslp, wslpi, wslpj ) 
    245260      ! 
    246261      IF( nn_timing == 1 )  CALL timing_stop('ldf_eiv') 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r7363 r7367  
    4444   !                                                                             !! Madec operator 
    4545   !  Arrays allocated in ldf_slp_init() routine once we know whether we're using the Griffies or Madec operator 
    46    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   uslp, wslpi          !: i_slope at U- and W-points 
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   vslp, wslpj          !: j-slope at V- and W-points 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   uslp_iso, wslpi_iso          !: i_slope at U- and W-points 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   vslp_iso, wslpj_iso          !: j-slope at V- and W-points 
     48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   uslp_hor, wslpi_hor          !: i_slope at U- and W-points 
     49   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   vslp_hor, wslpj_hor          !: j-slope at V- and W-points 
    4850   !                                                                !! Griffies operator 
    4951   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   wslp2                !: wslp**2 from Griffies quarter cells 
    … …  
    116118      CALL wrk_alloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 
    117119 
    118       zeps   =  1.e-20_wp        !==   Local constant initialization   ==! 
    119       z1_16  =  1.0_wp / 16._wp 
    120       zm1_g  = -1.0_wp / grav 
    121       zm1_2g = -0.5_wp / grav 
    122       ! 
    123       zww(:,:,:) = 0._wp 
    124       zwz(:,:,:) = 0._wp 
    125       ! 
    126       DO jk = 1, jpk             !==   i- & j-gradient of density   ==! 
    127          DO jj = 1, jpjm1 
    128             DO ji = 1, fs_jpim1   ! vector opt. 
    129                zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj  ,jk) - prd(ji,jj,jk) ) 
    130                zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji  ,jj+1,jk) - prd(ji,jj,jk) ) 
    131             END DO 
    132          END DO 
    133       END DO 
    134       IF( ln_zps ) THEN                           ! partial steps correction at the bottom ocean level 
     120      IF ( ( ln_traldf_hor .OR. ( ln_dynldf_lap_hor .and. ln_dynldf_lap ) .or. (ln_dynldf_bilap_hor .and. ln_dynldf_bilap ) )  &   
     121             .AND.  lk_vvl ) THEN   
     122   
     123        IF(lwp) THEN   
     124           WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces'   
     125        ENDIF   
     126   
     127        ! geopotential diffusion in s-coordinates on tracers and/or momentum   
     128        ! The slopes of s-surfaces are computed at each time step due to vvl   
     129        ! The slopes for momentum diffusion are i- or j- averaged of those on tracers   
     130    
     131        ! set the slope of diffusion to the slope of s-surfaces   
     132        !      ( c a u t i o n : minus sign as fsdep has positive value )   
     133        DO jk = 1, jpk   
     134           DO jj = 2, jpjm1   
     135              DO ji = fs_2, fs_jpim1   ! vector opt.   
     136                  uslp_hor(ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept(ji+1,jj,jk) - fsdept(ji ,jj ,jk) ) * umask(ji,jj,jk)   
     137                  vslp_hor(ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept(ji,jj+1,jk) - fsdept(ji ,jj ,jk) ) * vmask(ji,jj,jk)   
     138                 wslpi_hor(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw(ji+1,jj,jk) - fsdepw(ji-1,jj,jk) ) * tmask(ji,jj,jk) * 0.5   
     139                 wslpj_hor(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw(ji,jj+1,jk) - fsdepw(ji,jj-1,jk) ) * tmask(ji,jj,jk) * 0.5   
     140              END DO   
     141           END DO   
     142        END DO   
     143   
     144        ! Lateral boundary conditions on the slopes   
     145        CALL lbc_lnk( uslp_hor , 'U', -1. )      ;      CALL lbc_lnk( vslp_hor , 'V', -1. )   
     146        CALL lbc_lnk( wslpi_hor, 'W', -1. )      ;      CALL lbc_lnk( wslpj_hor, 'W', -1. )   
     147   
     148        if( kt == nit000 ) then   
     149           IF(lwp) WRITE(numout,*) ' max slop: u',SQRT( MAXVAL(uslp_hor*uslp_hor)), ' v ', SQRT(MAXVAL(vslp_hor)),  &   
     150              &                             ' wi', sqrt(MAXVAL(wslpi_hor)), ' wj', sqrt(MAXVAL(wslpj_hor))   
     151        endif   
     152   
     153        IF(ln_ctl) THEN   
     154           CALL prt_ctl(tab3d_1=uslp_hor , clinfo1=' slp  - u : ', tab3d_2=vslp_hor,  clinfo2=' v : ', kdim=jpk)   
     155           CALL prt_ctl(tab3d_1=wslpi_hor, clinfo1=' slp  - wi: ', tab3d_2=wslpj_hor, clinfo2=' wj: ', kdim=jpk)   
     156        ENDIF   
     157   
     158      ENDIF   
     159      IF ( ln_traldf_iso .OR. ( ln_dynldf_lap_iso .and. ln_dynldf_lap ) .or. (ln_dynldf_bilap_iso .and. ln_dynldf_bilap ) ) THEN   
     160   
     161         zeps   =  1.e-20_wp        !==   Local constant initialization   ==!  
     162         z1_16  =  1.0_wp / 16._wp  
     163         zm1_g  = -1.0_wp / grav  
     164         zm1_2g = -0.5_wp / grav  
     165         !  
     166         zww(:,:,:) = 0._wp  
     167         zwz(:,:,:) = 0._wp  
     168         !  
     169         DO jk = 1, jpk             !==   i- & j-gradient of density   ==!  
     170            DO jj = 1, jpjm1  
     171               DO ji = 1, fs_jpim1   ! vector opt.  
     172                  zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj  ,jk) - prd(ji,jj,jk) )   
     173                  zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji  ,jj+1,jk) - prd(ji,jj,jk) )   
     174               END DO  
     175            END DO  
     176         END DO  
     177         IF( ln_zps ) THEN                           ! partial steps correction at the bottom ocean level  
    135178# if defined key_vectopt_loop 
    136          DO jj = 1, 1 
    137             DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
     179           DO jj = 1, 1 
     180              DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    138181# else 
    139          DO jj = 1, jpjm1 
    140             DO ji = 1, jpim1 
     182           DO jj = 1, jpjm1 
     183              DO ji = 1, jpim1 
    141184# endif 
    142                zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
    143                zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
    144             END DO 
    145          END DO 
    146       ENDIF 
    147       ! 
    148       zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
    149       DO jk = 2, jpkm1 
    150          !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 
    151          !                                !   trick: tmask(ik  )  = 0   =>   all pn2   = 0   =>   zdzr = 0 
    152          !                                !    else  tmask(ik+1)  = 0   =>   pn2(ik+1) = 0   =>   zdzr divides by 1 
    153          !                                !          umask(ik+1) /= 0   =>   all pn2  /= 0   =>   zdzr divides by 2 
    154          !                                ! NB: 1/(tmask+1) = (1-.5*tmask)  substitute a / by a *  ==> faster 
    155          zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp )              & 
    156             &                 * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) ) 
    157       END DO 
    158       ! 
    159       !                          !==   Slopes just below the mixed layer   ==! 
    160       CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr )        ! output: uslpml, vslpml, wslpiml, wslpjml 
    161  
    162  
    163       ! I.  slopes at u and v point      | uslp = d/di( prd ) / d/dz( prd ) 
    164       ! ===========================      | vslp = d/dj( prd ) / d/dz( prd ) 
    165       ! 
    166       DO jk = 2, jpkm1                            !* Slopes at u and v points 
    167          DO jj = 2, jpjm1 
     185                 zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj) 
     186                 zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj) 
     187              END DO 
     188           END DO 
     189        ENDIF 
     190        ! 
     191        zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
     192        DO jk = 2, jpkm1 
     193           !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 
     194           !                                !   trick: tmask(ik  )  = 0   =>   all pn2   = 0   =>   zdzr = 0 
     195           !                                !    else  tmask(ik+1)  = 0   =>   pn2(ik+1) = 0   =>   zdzr divides by 1 
     196           !                                !          umask(ik+1) /= 0   =>   all pn2  /= 0   =>   zdzr divides by 2 
     197           !                                ! NB: 1/(tmask+1) = (1-.5*tmask)  substitute a / by a *  ==> faster 
     198           zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp )              & 
     199              &                 * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) ) 
     200        END DO 
     201        ! 
     202        !                          !==   Slopes just below the mixed layer   ==! 
     203        CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr )        ! output: uslpml, vslpml, wslpiml, wslpjml 
     204 
     205 
     206        ! I.  slopes at u and v point      | uslp = d/di( prd ) / d/dz( prd ) 
     207        ! ===========================      | vslp = d/dj( prd ) / d/dz( prd ) 
     208        ! 
     209        DO jk = 2, jpkm1                            !* Slopes at u and v points 
     210          DO jj = 2, jpjm1 
    168211            DO ji = fs_2, fs_jpim1   ! vector opt. 
    169212               !                                      ! horizontal and vertical density gradient at u- and v-points 
    … …  
    197240!!gm end modif 
    198241            END DO 
    199          END DO 
    200       END DO 
    201       CALL lbc_lnk( zwz, 'U', -1. )   ;   CALL lbc_lnk( zww, 'V', -1. )      ! lateral boundary conditions 
    202       ! 
    203       !                                            !* horizontal Shapiro filter 
    204       DO jk = 2, jpkm1 
    205          DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
    206             DO ji = 2, jpim1 
    207                uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    208                   &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
    209                   &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      & 
    210                   &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    & 
    211                   &                       + 4.*  zwz(ji  ,jj  ,jk)                       ) 
    212                vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      & 
    213                   &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      & 
    214                   &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      & 
    215                   &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    & 
    216                   &                       + 4.*  zww(ji,jj    ,jk)                       ) 
    217             END DO 
    218          END DO 
    219          DO jj = 3, jpj-2                               ! other rows 
    220             DO ji = fs_2, fs_jpim1   ! vector opt. 
    221                uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    222                   &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
    223                   &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      & 
    224                   &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    & 
    225                   &                       + 4.*  zwz(ji  ,jj  ,jk)                       ) 
    226                vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      & 
    227                   &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      & 
    228                   &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      & 
    229                   &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    & 
    230                   &                       + 4.*  zww(ji,jj    ,jk)                       ) 
    231             END DO 
    232          END DO 
    233          !                                        !* decrease along coastal boundaries 
    234          DO jj = 2, jpjm1 
    235             DO ji = fs_2, fs_jpim1   ! vector opt. 
    236                uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   & 
    237                   &                            * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp 
    238                vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk  ) ) * 0.5_wp   & 
    239                   &                            * ( vmask(ji  ,jj,jk) + vmask(ji  ,jj,jk+1) ) * 0.5_wp 
    240             END DO 
    241          END DO 
    242       END DO 
    243  
    244  
    245       ! II.  slopes at w point           | wslpi = mij( d/di( prd ) / d/dz( prd ) 
    246       ! ===========================      | wslpj = mij( d/dj( prd ) / d/dz( prd ) 
    247       ! 
    248       DO jk = 2, jpkm1 
    249          DO jj = 2, jpjm1 
    250             DO ji = fs_2, fs_jpim1   ! vector opt. 
    251                !                                  !* Local vertical density gradient evaluated from N^2 
    252                zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) 
    253                !                                  !* Slopes at w point 
    254                !                                        ! i- & j-gradient of density at w-points 
    255                zci = MAX(  umask(ji-1,jj,jk  ) + umask(ji,jj,jk  )           & 
    256                   &      + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps  ) * e1t(ji,jj) 
    257                zcj = MAX(  vmask(ji,jj-1,jk  ) + vmask(ji,jj,jk-1)           & 
    258                   &      + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk  ) , zeps  ) *  e2t(ji,jj) 
    259                zai =    (  zgru (ji-1,jj,jk  ) + zgru (ji,jj,jk-1)           & 
    260                   &      + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk  )   ) / zci * tmask (ji,jj,jk) 
    261                zaj =    (  zgrv (ji,jj-1,jk  ) + zgrv (ji,jj,jk-1)           & 
    262                   &      + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk  )   ) / zcj * tmask (ji,jj,jk) 
    263                !                                        ! bound the slopes: abs(zw.)<= 1/100 and zb..<0. 
    264                !                                        ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
    265                zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zai )  ) 
    266                zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zaj )  ) 
    267                !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 
    268                zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0 
    269                zck = fsdepw(ji,jj,jk) / MAX( hmlp(ji,jj), 10._wp ) 
    270                zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk  ) * tmask(ji,jj,jk) 
    271                zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk  ) * tmask(ji,jj,jk) 
     242          END DO 
     243        END DO 
     244        CALL lbc_lnk( zwz, 'U', -1. )   ;   CALL lbc_lnk( zww, 'V', -1. )      ! lateral boundary conditions 
     245        ! 
     246        !                                            !* horizontal Shapiro filter 
     247        DO jk = 2, jpkm1 
     248           DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
     249              DO ji = 2, jpim1 
     250                 uslp_iso(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
     251                    &                           +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
     252                    &                           + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      & 
     253                    &                           +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    & 
     254                    &                           + 4.*  zwz(ji  ,jj  ,jk)                       ) 
     255                 vslp_iso(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      & 
     256                    &                           +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      & 
     257                    &                           + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      & 
     258                    &                           +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    & 
     259                    &                           + 4.*  zww(ji,jj    ,jk)                       ) 
     260              END DO 
     261           END DO 
     262           DO jj = 3, jpj-2                               ! other rows 
     263              DO ji = fs_2, fs_jpim1   ! vector opt. 
     264                 uslp_iso(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
     265                    &                           +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
     266                    &                           + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      & 
     267                    &                           +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    & 
     268                    &                           + 4.*  zwz(ji  ,jj  ,jk)                       ) 
     269                 vslp_iso(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      & 
     270                    &                           +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      & 
     271                    &                           + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      & 
     272                    &                           +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    & 
     273                    &                           + 4.*  zww(ji,jj    ,jk)                       ) 
     274              END DO 
     275           END DO 
     276           !                                        !* decrease along coastal boundaries 
     277           DO jj = 2, jpjm1 
     278              DO ji = fs_2, fs_jpim1   ! vector opt. 
     279                 uslp_iso(ji,jj,jk) = uslp_iso(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   & 
     280                    &                                    * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp 
     281                 vslp_iso(ji,jj,jk) = vslp_iso(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk  ) ) * 0.5_wp   & 
     282                    &                                    * ( vmask(ji  ,jj,jk) + vmask(ji  ,jj,jk+1) ) * 0.5_wp 
     283              END DO 
     284           END DO 
     285        END DO 
     286 
     287 
     288        ! II.  slopes at w point           | wslpi = mij( d/di( prd ) / d/dz( prd ) 
     289        ! ===========================      | wslpj = mij( d/dj( prd ) / d/dz( prd ) 
     290        ! 
     291        DO jk = 2, jpkm1 
     292           DO jj = 2, jpjm1 
     293              DO ji = fs_2, fs_jpim1   ! vector opt. 
     294                 !                                  !* Local vertical density gradient evaluated from N^2 
     295                 zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) 
     296                 !                                  !* Slopes at w point 
     297                 !                                        ! i- & j-gradient of density at w-points 
     298                 zci = MAX(  umask(ji-1,jj,jk  ) + umask(ji,jj,jk  )           & 
     299                    &      + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps  ) * e1t(ji,jj) 
     300                 zcj = MAX(  vmask(ji,jj-1,jk  ) + vmask(ji,jj,jk-1)           & 
     301                    &      + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk  ) , zeps  ) *  e2t(ji,jj) 
     302                 zai =    (  zgru (ji-1,jj,jk  ) + zgru (ji,jj,jk-1)           & 
     303                    &      + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk  )   ) / zci * tmask (ji,jj,jk) 
     304                 zaj =    (  zgrv (ji,jj-1,jk  ) + zgrv (ji,jj,jk-1)           & 
     305                    &      + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk  )   ) / zcj * tmask (ji,jj,jk) 
     306                 !                                        ! bound the slopes: abs(zw.)<= 1/100 and zb..<0. 
     307                 !                                        ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 
     308                 zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zai )  ) 
     309                 zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zaj )  ) 
     310                 !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.) 
     311                 zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0 
     312                 zck = fsdepw(ji,jj,jk) / MAX( hmlp(ji,jj), 10._wp ) 
     313                 zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk  ) * tmask(ji,jj,jk) 
     314                 zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk  ) * tmask(ji,jj,jk) 
    272315 
    273316!!gm  modif to suppress omlmask....  (as in Griffies operator) 
    274 !               !                                         ! jk must be >= ML level for zfk=1. otherwise  zfk=0. 
    275 !               zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) 
    276 !               zck = fsdepw(ji,jj,jk)    / MAX( hmlp(ji,jj), 10. ) 
    277 !               zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) 
    278 !               zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) 
     317!                 !                                         ! jk must be >= ML level for zfk=1. otherwise  zfk=0. 
     318!                 zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp ) 
     319!                 zck = fsdepw(ji,jj,jk)    / MAX( hmlp(ji,jj), 10. ) 
     320!                 zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk) 
     321!                 zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk) 
    279322!!gm end modif 
    280             END DO 
    281          END DO 
    282       END DO 
    283       CALL lbc_lnk( zwz, 'T', -1. )   ;    CALL lbc_lnk( zww, 'T', -1. )      ! lateral boundary conditions 
    284       ! 
    285       !                                           !* horizontal Shapiro filter 
    286       DO jk = 2, jpkm1 
    287          DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
    288             DO ji = 2, jpim1 
    289                zcofw = tmask(ji,jj,jk) * z1_16 
    290                wslpi(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
    291                     &                +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
    292                     &                + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     & 
    293                     &                +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   & 
    294                     &                + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw 
    295  
    296                wslpj(ji,jj,jk) = (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     & 
    297                     &                +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     & 
    298                     &                + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     & 
    299                     &                +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   & 
    300                     &                + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw 
    301             END DO 
    302          END DO 
    303          DO jj = 3, jpj-2                               ! other rows 
    304             DO ji = fs_2, fs_jpim1   ! vector opt. 
    305                zcofw = tmask(ji,jj,jk) * z1_16 
    306                wslpi(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
    307                     &                +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
    308                     &                + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     & 
    309                     &                +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   & 
    310                     &                + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw 
    311  
    312                wslpj(ji,jj,jk) = (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     & 
    313                     &                +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     & 
    314                     &                + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     & 
    315                     &                +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   & 
    316                     &                + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw 
    317             END DO 
    318          END DO 
    319          !                                        !* decrease along coastal boundaries 
    320          DO jj = 2, jpjm1 
    321             DO ji = fs_2, fs_jpim1   ! vector opt. 
    322                zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   & 
    323                   &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 
    324                wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck 
    325                wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck 
    326             END DO 
    327          END DO 
    328       END DO 
    329  
    330       ! III.  Specific grid points 
    331       ! =========================== 
    332       ! 
    333       IF( cp_cfg == "orca" .AND. jp_cfg == 4 ) THEN     !  ORCA_R4 configuration: horizontal diffusion in specific area 
    334          !                                                    ! Gibraltar Strait 
    335          ij0 =  50   ;   ij1 =  53 
    336          ii0 =  69   ;   ii1 =  71   ;   uslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    337          ij0 =  51   ;   ij1 =  53 
    338          ii0 =  68   ;   ii1 =  71   ;   vslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    339          ii0 =  69   ;   ii1 =  71   ;   wslpi( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    340          ii0 =  69   ;   ii1 =  71   ;   wslpj( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    341          ! 
    342          !                                                    ! Mediterrannean Sea 
    343          ij0 =  49   ;   ij1 =  56 
    344          ii0 =  71   ;   ii1 =  90   ;   uslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    345          ij0 =  50   ;   ij1 =  56 
    346          ii0 =  70   ;   ii1 =  90   ;   vslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    347          ii0 =  71   ;   ii1 =  90   ;   wslpi( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    348          ii0 =  71   ;   ii1 =  90   ;   wslpj( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
    349       ENDIF 
    350  
    351  
    352       ! IV. Lateral boundary conditions 
    353       ! =============================== 
    354       CALL lbc_lnk( uslp , 'U', -1. )      ;      CALL lbc_lnk( vslp , 'V', -1. ) 
    355       CALL lbc_lnk( wslpi, 'W', -1. )      ;      CALL lbc_lnk( wslpj, 'W', -1. ) 
    356  
    357  
    358       IF(ln_ctl) THEN 
    359          CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp  - u : ', tab3d_2=vslp,  clinfo2=' v : ', kdim=jpk) 
    360          CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp  - wi: ', tab3d_2=wslpj, clinfo2=' wj: ', kdim=jpk) 
    361       ENDIF 
     323              END DO 
     324           END DO 
     325        END DO 
     326        CALL lbc_lnk( zwz, 'T', -1. )   ;    CALL lbc_lnk( zww, 'T', -1. )      ! lateral boundary conditions 
     327        ! 
     328        !                                           !* horizontal Shapiro filter 
     329        DO jk = 2, jpkm1 
     330           DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
     331              DO ji = 2, jpim1 
     332                 zcofw = tmask(ji,jj,jk) * z1_16 
     333                 wslpi_iso(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
     334                      &                  +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
     335                      &                  + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     & 
     336                      &                  +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   & 
     337                      &                  + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw 
     338 
     339                 wslpj_iso(ji,jj,jk) = (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     & 
     340                      &                  +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     & 
     341                      &                  + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     & 
     342                      &                  +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   & 
     343                      &                  + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw 
     344              END DO 
     345           END DO 
     346           DO jj = 3, jpj-2                               ! other rows 
     347              DO ji = fs_2, fs_jpim1   ! vector opt. 
     348                 zcofw = tmask(ji,jj,jk) * z1_16 
     349                 wslpi_iso(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
     350                      &                  +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
     351                      &                  + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     & 
     352                      &                  +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   & 
     353                      &                  + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw 
     354 
     355                 wslpj_iso(ji,jj,jk) = (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     & 
     356                      &                  +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     & 
     357                      &                  + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     & 
     358                      &                  +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   & 
     359                      &                  + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw 
     360              END DO 
     361           END DO 
     362           !                                        !* decrease along coastal boundaries 
     363           DO jj = 2, jpjm1 
     364              DO ji = fs_2, fs_jpim1   ! vector opt. 
     365                 zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   & 
     366                    &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 
     367                 wslpi_iso(ji,jj,jk) = wslpi_iso(ji,jj,jk) * zck 
     368                 wslpj_iso(ji,jj,jk) = wslpj_iso(ji,jj,jk) * zck 
     369              END DO 
     370           END DO 
     371        END DO 
     372 
     373        ! III.  Specific grid points 
     374        ! =========================== 
     375        ! 
     376        IF( cp_cfg == "orca" .AND. jp_cfg == 4 ) THEN     !  ORCA_R4 configuration: horizontal diffusion in specific area 
     377           !                                                    ! Gibraltar Strait 
     378           ij0 =  50   ;   ij1 =  53 
     379           ii0 =  69   ;   ii1 =  71   ;   uslp_iso ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     380           ij0 =  51   ;   ij1 =  53 
     381           ii0 =  68   ;   ii1 =  71   ;   vslp_iso ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     382           ii0 =  69   ;   ii1 =  71   ;   wslpi_iso( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     383           ii0 =  69   ;   ii1 =  71   ;   wslpj_iso( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     384           ! 
     385           !                                                    ! Mediterrannean Sea 
     386           ij0 =  49   ;   ij1 =  56 
     387           ii0 =  71   ;   ii1 =  90   ;   uslp_iso ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     388           ij0 =  50   ;   ij1 =  56 
     389           ii0 =  70   ;   ii1 =  90   ;   vslp_iso ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     390           ii0 =  71   ;   ii1 =  90   ;   wslpi_iso( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     391           ii0 =  71   ;   ii1 =  90   ;   wslpj_iso( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp 
     392        ENDIF 
     393 
     394 
     395        ! IV. Lateral boundary conditions 
     396        ! =============================== 
     397        CALL lbc_lnk( uslp_iso , 'U', -1. )      ;      CALL lbc_lnk( vslp_iso , 'V', -1. ) 
     398        CALL lbc_lnk( wslpi_iso, 'W', -1. )      ;      CALL lbc_lnk( wslpj_iso, 'W', -1. ) 
     399 
     400 
     401        IF(ln_ctl) THEN 
     402           CALL prt_ctl(tab3d_1=uslp_iso , clinfo1=' slp  - u : ', tab3d_2=vslp_iso,  clinfo2=' v : ', kdim=jpk) 
     403           CALL prt_ctl(tab3d_1=wslpi_iso, clinfo1=' slp  - wi: ', tab3d_2=wslpj_iso, clinfo2=' wj: ', kdim=jpk) 
     404        ENDIF 
     405        ! 
     406      ELSE IF ( ln_traldf_hor .AND. ( (ln_dynldf_lap_iso   .and. ln_dynldf_lap) .or.   &   
     407                                      (ln_dynldf_bilap_iso .and. ln_dynldf_bilap) )  ) THEN   
     408        CALL ctl_stop( 'cannot use geopotential diffusion for tracers and isoneutral diffusion on momentum')   
     409      ENDIF    
    362410      ! 
    363411      CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 
    … …  
    494542               DO ji = 1, fs_jpim1 
    495543                  ip = jl   ;   jp = jl 
    496                   jk = MIN( nmln(ji+ip,jj) , mbkt(ji+ip,jj) ) + 1         ! ML level+1 (MIN in case ML depth is the ocean depth) 
    497                   ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth) 
    498                   zti_g_raw = (  zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp)      & 
    499                      &      - ( fsdept(ji+1,jj,jk-kp) - fsdept(ji,jj,jk-kp) ) / e1u(ji,jj)  ) * umask(ji,jj,jk) 
    500                   jk = MIN( nmln(ji,jj+jp) , mbkt(ji,jj+jp) ) + 1 
    501                   ztj_g_raw = (  zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp)      & 
    502                      &      - ( fsdept(ji,jj+1,jk-kp) - fsdept(ji,jj,jk-kp) ) / e2v(ji,jj)  ) * vmask(ji,jj,jk) 
    503                   zti_mlb(ji+ip,jj   ,1-ip,kp) = SIGN( MIN( rn_slpmax, ABS( zti_g_raw ) ), zti_g_raw ) 
    504                   ztj_mlb(ji   ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, ABS( ztj_g_raw ) ), ztj_g_raw ) 
     544                  !  
     545                  jk = nmln(ji+ip,jj) + 1  
     546                  IF( jk .GT. mbkt(ji+ip,jj) ) THEN  !ML reaches bottom  
     547                    zti_mlb(ji+ip,jj   ,1-ip,kp) = 0.0_wp  
     548                  ELSE  
     549                    ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)  
     550                    zti_g_raw = (  zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp)      &  
     551                       &      - ( fsdept(ji+1,jj,jk-kp) - fsdept(ji,jj,jk-kp) ) / e1u(ji,jj)  ) * umask(ji,jj,jk)  
     552                    zti_mlb(ji+ip,jj   ,1-ip,kp) = SIGN( MIN( rn_slpmax, ABS( zti_g_raw ) ), zti_g_raw )  
     553                  ENDIF  
     554                  !  
     555                  jk = nmln(ji,jj+jp) + 1  
     556                  IF( jk .GT. mbkt(ji,jj+jp) ) THEN  !ML reaches bottom  
     557                    ztj_mlb(ji   ,jj+jp,1-jp,kp) = 0.0_wp  
     558                  ELSE  
     559                    ztj_g_raw = (  zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp)      &  
     560                       &      - ( fsdept(ji,jj+1,jk-kp) - fsdept(ji,jj,jk-kp) ) / e2v(ji,jj)  ) * vmask(ji,jj,jk)  
     561                    ztj_mlb(ji   ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, ABS( ztj_g_raw ) ), ztj_g_raw )  
     562                  ENDIF  
    505563               END DO 
    506564            END DO 
    … …  
    758816         IF( ierr > 0             )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' ) 
    759817         ! 
    760          IF( ln_dynldf_iso )   CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' ) 
     818!         IF( (ln_dynldf_lap .and. ln_dynldf_lap_iso) .OR. (ln_dynldf_bilap .and. ln_dynldf_bilap_iso) ) &  
     819!                           CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' )  
    761820         ! 
    762       ELSE                             ! Madec operator : slopes at u-, v-, and w-points 
    763          ALLOCATE( uslp(jpi,jpj,jpk) , vslp(jpi,jpj,jpk) , wslpi(jpi,jpj,jpk) , wslpj(jpi,jpj,jpk) ,                & 
    764             &   omlmask(jpi,jpj,jpk) , uslpml(jpi,jpj)   , vslpml(jpi,jpj)    , wslpiml(jpi,jpj)   , wslpjml(jpi,jpj) , STAT=ierr ) 
    765          IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 
    766  
    767          ! Direction of lateral diffusion (tracers and/or momentum) 
    768          ! ------------------------------ 
    769          uslp (:,:,:) = 0._wp   ;   uslpml (:,:) = 0._wp      ! set the slope to zero (even in s-coordinates) 
    770          vslp (:,:,:) = 0._wp   ;   vslpml (:,:) = 0._wp 
    771          wslpi(:,:,:) = 0._wp   ;   wslpiml(:,:) = 0._wp 
    772          wslpj(:,:,:) = 0._wp   ;   wslpjml(:,:) = 0._wp 
    773  
    774          !!gm I no longer understand this..... 
    775          IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (lk_vvl .AND. ln_rstart) ) THEN 
    776             IF(lwp)   WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 
    777  
    778             ! geopotential diffusion in s-coordinates on tracers and/or momentum 
    779             ! The slopes of s-surfaces are computed once (no call to ldfslp in step) 
    780             ! The slopes for momentum diffusion are i- or j- averaged of those on tracers 
    781  
    782             ! set the slope of diffusion to the slope of s-surfaces 
    783             !      ( c a u t i o n : minus sign as fsdep has positive value ) 
    784             DO jk = 1, jpk 
    785                DO jj = 2, jpjm1 
    786                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    787                      uslp (ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept(ji+1,jj,jk) - fsdept(ji ,jj ,jk) ) * umask(ji,jj,jk) 
    788                      vslp (ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept(ji,jj+1,jk) - fsdept(ji ,jj ,jk) ) * vmask(ji,jj,jk) 
    789                      wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw(ji+1,jj,jk) - fsdepw(ji-1,jj,jk) ) * tmask(ji,jj,jk) * 0.5 
    790                      wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw(ji,jj+1,jk) - fsdepw(ji,jj-1,jk) ) * tmask(ji,jj,jk) * 0.5 
    791                   END DO 
     821      ENDIF 
     822      !ELSE                             ! Madec operator : slopes at u-, v-, and w-points 
     823      ALLOCATE( uslp_iso(jpi,jpj,jpk) , vslp_iso(jpi,jpj,jpk) , wslpi_iso(jpi,jpj,jpk) , wslpj_iso(jpi,jpj,jpk) ,                & 
     824         &      uslp_hor(jpi,jpj,jpk) , vslp_hor(jpi,jpj,jpk) , wslpi_hor(jpi,jpj,jpk) , wslpj_hor(jpi,jpj,jpk) ,                & 
     825         &   omlmask(jpi,jpj,jpk) , uslpml(jpi,jpj)   , vslpml(jpi,jpj)    , wslpiml(jpi,jpj)   , wslpjml(jpi,jpj) , STAT=ierr ) 
     826      IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 
     827 
     828      ! Direction of lateral diffusion (tracers and/or momentum) 
     829      ! ------------------------------ 
     830      uslp_hor (:,:,:) = 0._wp   ;   uslp_iso (:,:,:) = 0._wp   ;   uslpml (:,:) = 0._wp      ! set the slope to zero (even in s-coordinates)  
     831      vslp_hor (:,:,:) = 0._wp   ;   vslp_iso (:,:,:) = 0._wp   ;   vslpml (:,:) = 0._wp  
     832      wslpi_hor(:,:,:) = 0._wp   ;   wslpi_iso(:,:,:) = 0._wp   ;   wslpiml(:,:) = 0._wp  
     833      wslpj_hor(:,:,:) = 0._wp   ;   wslpj_iso(:,:,:) = 0._wp   ;   wslpjml(:,:) = 0._wp  
     834 
     835      !!gm I no longer understand this..... 
     836      IF( ( ln_traldf_hor .OR. (ln_dynldf_lap_hor .and. ln_dynldf_lap) .or. (ln_dynldf_bilap_hor .and. ln_dynldf_bilap) )  &   
     837                .AND. .NOT. ( lk_vvl .AND. ln_rstart ) ) THEN 
     838         IF(lwp)   WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 
     839 
     840         ! geopotential diffusion in s-coordinates on tracers and/or momentum 
     841         ! The slopes of s-surfaces are computed once (no call to ldfslp in step) 
     842         ! The slopes for momentum diffusion are i- or j- averaged of those on tracers 
     843 
     844         ! set the slope of diffusion to the slope of s-surfaces 
     845         !      ( c a u t i o n : minus sign as fsdep has positive value ) 
     846         DO jk = 1, jpk 
     847            DO jj = 2, jpjm1 
     848               DO ji = fs_2, fs_jpim1   ! vector opt. 
     849                  uslp_hor (ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept(ji+1,jj,jk) - fsdept(ji ,jj ,jk) ) * umask(ji,jj,jk) 
     850                  vslp_hor (ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept(ji,jj+1,jk) - fsdept(ji ,jj ,jk) ) * vmask(ji,jj,jk) 
     851                  wslpi_hor(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw(ji+1,jj,jk) - fsdepw(ji-1,jj,jk) ) * tmask(ji,jj,jk) * 0.5 
     852                  wslpj_hor(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw(ji,jj+1,jk) - fsdepw(ji,jj-1,jk) ) * tmask(ji,jj,jk) * 0.5 
    792853               END DO 
    793854            END DO 
    794             CALL lbc_lnk( uslp , 'U', -1. )   ;   CALL lbc_lnk( vslp , 'V', -1. )      ! Lateral boundary conditions 
    795             CALL lbc_lnk( wslpi, 'W', -1. )   ;   CALL lbc_lnk( wslpj, 'W', -1. ) 
    796          ENDIF 
     855         END DO 
     856         CALL lbc_lnk( uslp_hor , 'U', -1. )   ;   CALL lbc_lnk( vslp_hor , 'V', -1. )      ! Lateral boundary conditions 
     857         CALL lbc_lnk( wslpi_hor, 'W', -1. )   ;   CALL lbc_lnk( wslpj_hor, 'W', -1. ) 
    797858      ENDIF 
     859!      ENDIF 
    798860      ! 
    799861      IF( nn_timing == 1 )  CALL timing_stop('ldf_slp_init') 

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

    r7363 r7367  
    2424   USE obs_read_sla             ! Reading and allocation of SLA observations   
    2525   USE obs_read_sst             ! Reading and allocation of SST observations   
     26   USE obs_sstbias              ! Bias correction routine for SST 
    2627   USE obs_readmdt              ! Reading and allocation of MDT for SLA. 
    2728   USE obs_read_seaice          ! Reading and allocation of Sea Ice observations   
    … …  
    6869   LOGICAL, PUBLIC :: ln_slafb       !: Logical switch for SLA from feedback files 
    6970   LOGICAL, PUBLIC :: ln_sst         !: Logical switch for sea surface temperature 
    70    LOGICAL, PUBLIC :: ln_reysst      !: Logical switch for Reynolds sea surface temperature 
     71   LOGICAL, PUBLIC :: ln_grdsst      !: Logical switch for gridded sea surface temperature 
    7172   LOGICAL, PUBLIC :: ln_ghrsst      !: Logical switch for GHRSST data 
    7273   LOGICAL, PUBLIC :: ln_sstfb       !: Logical switch for SST from feedback files 
    7374   LOGICAL, PUBLIC :: ln_seaice      !: Logical switch for sea ice concentration 
     75   LOGICAL, PUBLIC :: ln_grdseaice   !: Logical switch for sea ice concentration from gridded fields 
     76   LOGICAL, PUBLIC :: ln_seaicefb    !: Logical switch for sea ice concentration from feedback files 
    7477   LOGICAL, PUBLIC :: ln_vel3d       !: Logical switch for velocity component (u,v) observations 
    7578   LOGICAL, PUBLIC :: ln_velavcur    !: Logical switch for raw daily averaged netCDF current meter vel. data  
    … …  
    8487   LOGICAL, PUBLIC :: ln_ignmis      !: Logical switch for ignoring missing files 
    8588   LOGICAL, PUBLIC :: ln_s_at_t      !: Logical switch to compute model S at T observations 
    86  
     89   LOGICAL, PUBLIC :: ln_sstbias     !: Logical switch for bias corection of SST 
     90    
     91   CHARACTER(len=5) :: sstbias_name  !: Name of SST bias variable in file  
     92    
    8793   REAL(KIND=dp), PUBLIC :: dobsini   !: Observation window start date YYYYMMDD.HHMMSS 
    8894   REAL(KIND=dp), PUBLIC :: dobsend   !: Observation window end date YYYYMMDD.HHMMSS 
    … …  
    99105   !                    !: If so use endailyavtypes 
    100106      & ln_profb_enatim !: Change tim for 820 enact data set. 
     107       
     108   INTEGER, DIMENSION(MaxNumFiles), PUBLIC :: sstbias_type !SST bias type    
    101109    
    102110   LOGICAL, DIMENSION(MaxNumFiles) :: & 
    … …  
    112120   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    113121   !!---------------------------------------------------------------------- 
     122 
     123!! * Substitutions 
     124#include "domzgr_substitute.h90" 
    114125 
    115126CONTAINS 
    … …  
    130141      !!        !  06-10  (A. Weaver) Cleaning and add controls 
    131142      !!        !  07-03  (K. Mogensen) General handling of profiles 
     143      !!        ! 2011-08 (D. Lea) Handle sea ice files in feedback format 
     144      !!        !  11-07  (J.While) Incorporated SST bias correction  
    132145      !!---------------------------------------------------------------------- 
    133146 
    … …  
    139152      CHARACTER(len=128) :: profbfiles(MaxNumFiles) 
    140153      CHARACTER(len=128) :: sstfiles(MaxNumFiles)       
    141       CHARACTER(len=128) :: sstfbfiles(MaxNumFiles)  
     154      CHARACTER(len=128) :: sstfbfiles(MaxNumFiles) 
     155      CHARACTER(len=128) :: sstbias_files(MaxNumFiles)  
    142156      CHARACTER(len=128) :: slafilesact(MaxNumFiles)       
    143157      CHARACTER(len=128) :: slafilespas(MaxNumFiles)       
    144158      CHARACTER(len=128) :: slafbfiles(MaxNumFiles) 
    145159      CHARACTER(len=128) :: seaicefiles(MaxNumFiles)            
     160      CHARACTER(len=128) :: seaicefbfiles(MaxNumFiles)            
    146161      CHARACTER(len=128) :: velcurfiles(MaxNumFiles)   
    147162      CHARACTER(len=128) :: veladcpfiles(MaxNumFiles)     
    … …  
    151166      CHARACTER(len=128) :: velhradcpfiles(MaxNumFiles) 
    152167      CHARACTER(len=128) :: velfbfiles(MaxNumFiles) 
    153       CHARACTER(LEN=128) :: reysstname 
    154       CHARACTER(LEN=12)  :: reysstfmt 
     168      CHARACTER(LEN=128) :: grdsstname, grdseaicename 
     169      CHARACTER(LEN=12)  :: grdsstfmt, grdseaicefmt 
    155170      CHARACTER(LEN=128) :: bias_file 
    156171      CHARACTER(LEN=20)  :: datestr=" ", timestr=" " 
    … …  
    158173         &            ln_sla, ln_sladt, ln_slafb,                     & 
    159174         &            ln_ssh, ln_sst, ln_sstfb, ln_sss, ln_nea,       & 
     175         &            ln_bound_reject,                                &           
    160176         &            enactfiles, coriofiles, profbfiles,             & 
    161177         &            slafilesact, slafilespas, slafbfiles,           & 
    162178         &            sstfiles, sstfbfiles,                           & 
    163          &            ln_seaice, seaicefiles,                         & 
     179         &            ln_seaice, ln_seaicefb, ln_grdseaice,           & 
     180         &            seaicefiles, seaicefbfiles,                     & 
     181         &            grdseaicename, grdseaicefmt,                    & 
    164182         &            dobsini, dobsend, n1dint, n2dint,               & 
    165183         &            nmsshc, mdtcorr, mdtcutoff,                     & 
    166          &            ln_reysst, ln_ghrsst, reysstname, reysstfmt,    & 
     184         &            ln_grdsst, ln_ghrsst, grdsstname, grdsstfmt,    & 
    167185         &            ln_grid_search_lookup,                          & 
    168186         &            grid_search_file, grid_search_res,              & 
    … …  
    174192         &            ln_velhradcp, velhradcpfiles,                   & 
    175193         &            ln_velfb, velfbfiles, ln_velfb_av,              & 
    176          &            ln_profb_enatim, ln_ignmis 
     194         &            ln_profb_enatim, ln_ignmis,                     & 
     195         &            ln_sstbias, sstbias_files, sstbias_name 
    177196 
    178197      INTEGER :: jprofset 
    … …  
    187206      INTEGER :: jnumsst 
    188207      INTEGER :: jnumsstfb 
     208      INTEGER :: jnumsstbias 
    189209      INTEGER :: jnumseaice 
     210      INTEGER :: jnumseaicefb 
    190211      INTEGER :: jnumvelavcur 
    191212      INTEGER :: jnumvelhrcur   
    … …  
    210231      ln_sst = .FALSE. 
    211232      ln_seaice = .FALSE. 
    212       ln_reysst = .FALSE. 
     233      ln_grdsst = .FALSE. 
    213234      ln_ghrsst = .FALSE. 
    214235      ln_sss = .FALSE. 
    … …  
    219240      ln_slafb = .FALSE. 
    220241      ln_sstfb = .FALSE. 
     242      ln_seaicefb = .FALSE. 
     243      ln_sstbias = .TRUE. 
    221244      ln_velavcur = .FALSE. 
    222245      ln_velhrcur = .FALSE. 
    … …  
    225248      ln_velfb = .FALSE. 
    226249      ln_nea = .FALSE. 
     250      ln_bound_reject = .TRUE.  
    227251      ln_grid_search_lookup = .FALSE. 
    228252      ln_grid_global = .FALSE. 
    229253      ln_s_at_t = .TRUE. 
     254      sstbias_name = "tn" 
    230255      grid_search_file = 'xypos' 
    231       bias_file='bias.nc' 
     256      bias_file='bias' 
    232257      enactfiles(:) = '' 
    233258      coriofiles(:) = '' 
    … …  
    238263      sstfiles(:)   = '' 
    239264      sstfbfiles(:) = '' 
     265      sstbias_files(:) = '' 
    240266      seaicefiles(:) = '' 
     267      seaicefbfiles(:) = '' 
    241268      velcurfiles(:) = '' 
    242269      veladcpfiles(:) = '' 
    … …  
    246273      velhradcpfiles(:) = '' 
    247274      velfbfiles(:) = '' 
    248       reysstname = 'sst_yYYYYmMM.nc' 
    249       reysstfmt = 'monthly' 
     275      grdsstname = 'sst_yYYYYmMM.nc' 
     276      grdsstfmt = 'monthly' 
     277      grdseaicename = 'ice_cov_yYYYYmMM.nc' 
     278      grdseaicefmt = 'monthly' 
    250279      endailyavtypes(:) = -1 
    251280      endailyavtypes(1) = 820 
    … …  
    304333         lmask(:) = .FALSE. 
    305334      ENDIF 
     335      IF (ln_sstbias) THEN 
     336         lmask(:) = .FALSE. 
     337         WHERE (sstbias_files(:) /= '') lmask(:) = .TRUE. 
     338         jnumsstbias = COUNT(lmask) 
     339         lmask(:) = .FALSE. 
     340      ENDIF    
    306341      IF (ln_seaice) THEN 
    307342         lmask(:) = .FALSE. 
    308343         WHERE (seaicefiles(:) /= '') lmask(:) = .TRUE. 
    309344         jnumseaice = COUNT(lmask) 
     345      ENDIF 
     346      IF (ln_seaicefb) THEN 
     347         lmask(:) = .FALSE. 
     348         WHERE (seaicefbfiles(:) /= '') lmask(:) = .TRUE. 
     349         jnumseaicefb = COUNT(lmask) 
    310350      ENDIF 
    311351      IF (ln_velavcur) THEN 
    … …  
    352392         WRITE(numout,*) '             Logical switch for SSH observations                ln_ssh = ', ln_ssh 
    353393         WRITE(numout,*) '             Logical switch for SST observations                ln_sst = ', ln_sst 
    354          WRITE(numout,*) '             Logical switch for Reynolds observations        ln_reysst = ', ln_reysst     
     394         WRITE(numout,*) '             Logical switch for gridded observations         ln_grdsst = ', ln_grdsst     
    355395         WRITE(numout,*) '             Logical switch for GHRSST observations          ln_ghrsst = ', ln_ghrsst 
    356396         WRITE(numout,*) '             Logical switch for feedback SST data             ln_sstfb = ', ln_sstfb 
     397         WRITE(numout,*) '             Logical switch for SST bias correction         ln_sstbias = ', ln_sstbias 
    357398         WRITE(numout,*) '             Logical switch for SSS observations                ln_sss = ', ln_sss 
    358399         WRITE(numout,*) '             Logical switch for Sea Ice observations         ln_seaice = ', ln_seaice 
     400         WRITE(numout,*) '             Logical switch for feedback Sea Ice data      ln_seaicefb = ', ln_seaicefb 
     401         WRITE(numout,*) '             Logical switch for gridded Sea Ice data    ln_grdseaicefb = ', ln_grdseaice 
    359402         WRITE(numout,*) '             Logical switch for velocity observations         ln_vel3d = ', ln_vel3d 
    360403         WRITE(numout,*) '             Logical switch for velocity daily av. cur.    ln_velavcur = ', ln_velavcur 
    … …  
    389432                     TRIM(profbfiles(ji)) 
    390433               ENDIF 
    391                WRITE(numout,'(1X,2A)') '       Enact feedback input time setting switch    ln_profb_enatim = ', ln_profb_enatim(ji) 
     434               WRITE(numout,'(1X,A,L)') '       Enact feedback input time setting switch    ln_profb_enatim = ', ln_profb_enatim(ji) 
    392435            END DO 
    393436         ENDIF 
    … …  
    424467               WRITE(numout,'(1X,2A)') '             Sea Ice input observation file name       seaicefiles = ', & 
    425468                  TRIM(seaicefiles(ji)) 
     469            END DO 
     470         ENDIF 
     471         IF (ln_seaicefb) THEN 
     472            DO ji = 1, jnumseaicefb 
     473               WRITE(numout,'(1X,2A)') '             Feedback Sea Ice input observation file name  seaicefbfiles = ', & 
     474                  TRIM(seaicefbfiles(ji)) 
    426475            END DO 
    427476         ENDIF 
    … …  
    466515         WRITE(numout,*) '             Type of horizontal interpolation method        n2dint = ', n2dint 
    467516         WRITE(numout,*) '             Rejection of observations near land swithch    ln_nea = ', ln_nea 
     517         WRITE(numout,*) '             Rejection of obs near open bdys       ln_bound_reject = ', ln_bound_reject  
    468518         WRITE(numout,*) '             MSSH correction scheme                         nmsshc = ', nmsshc 
    469519         WRITE(numout,*) '             MDT  correction                               mdtcorr = ', mdtcorr 
    … …  
    633683      !  - Sea level anomalies 
    634684      IF ( ln_sla ) THEN 
    635         ! Set the number of variables for sla to 1 
     685         ! Set the number of variables for sla to 1 
    636686         nslavars = 1 
    637687 
    … …  
    729779         nsstsets = 0 
    730780 
    731          IF (ln_reysst) nsstsets = nsstsets + 1 
     781         IF (ln_grdsst) nsstsets = nsstsets + 1 
    732782         IF (ln_ghrsst) nsstsets = nsstsets + 1 
    733783         IF ( ln_sstfb ) THEN 
    … …  
    742792         nsstsets = 0 
    743793 
    744          IF (ln_reysst) THEN 
     794         IF (ln_grdsst) THEN 
    745795 
    746796            nsstsets = nsstsets + 1 
    747797 
    748             CALL obs_rea_sst_rey( reysstname, reysstfmt, sstdata(nsstsets), & 
     798            CALL obs_rea_sst_grd( grdsstname, grdsstfmt, sstdata(nsstsets), & 
    749799               &                  nsstvars, nsstextr, & 
    750800               &                  nitend-nit000+2, dobsini, dobsend ) 
    … …  
    752802               &              ln_nea ) 
    753803 
    754         ENDIF 
    755          
    756         IF (ln_ghrsst) THEN 
     804         ENDIF 
     805 
     806         IF (ln_ghrsst) THEN 
    757807         
    758808            nsstsets = nsstsets + 1 
    … …  
    761811               &              sstfiles(1:jnumsst), & 
    762812               &              nsstvars, nsstextr, nitend-nit000+2, & 
    763                &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
     813               &              dobsini, dobsend, ln_ignmis, .FALSE., .FALSE. ) 
    764814            CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), ln_sst, & 
    765815               &              ln_nea ) 
    766816 
    767         ENDIF 
     817         ENDIF 
    768818                
    769819         ! Feedback SST data 
    … …  
    778828                  &              sstfbfiles(jset:jset), & 
    779829                  &              nsstvars, nsstextr, nitend-nit000+2, & 
    780                   &              dobsini, dobsend, ln_ignmis, .FALSE. ) 
     830                  &              dobsini, dobsend, ln_ignmis, .FALSE., .FALSE. ) 
    781831               CALL obs_pre_sst( sstdata(nsstsets), sstdatqc(nsstsets), & 
    782832                  &              ln_sst, ln_nea ) 
    … …  
    784834            END DO                
    785835 
     836         ENDIF 
     837          
     838         !Read in the SST bias 
     839 
     840         IF ( ln_sstbias ) THEN  
     841            IF ( jnumsstbias == 0 ) CALL ctl_stop("ln_sstbias set,"// & 
     842                                             "  but no bias"// & 
     843                                             " files to read in")     
     844            CALL obs_app_sstbias( nsstsets, sstdatqc, n2dint, & 
     845                                  jnumsstbias, &  
     846                                  sstbias_files(1:jnumsstbias), sstbias_name ) 
    786847         ENDIF 
    787848 
    … …  
    803864         nseaiceextr = 0 
    804865          
    805          ! Set the number of data sets to 1 
    806          nseaicesets = 1 
     866         IF ( ln_seaicefb ) THEN 
     867            nseaicesets = jnumseaicefb 
     868         ELSE 
     869            nseaicesets = 1 
     870         ENDIF 
    807871 
    808872         ALLOCATE(seaicedata(nseaicesets)) 
    … …  
    811875         seaicedatqc(:)%nsurf=0 
    812876 
    813          CALL obs_rea_seaice( 1, seaicedata(nseaicesets), jnumseaice, & 
    814             &                 seaicefiles(1:jnumseaice), & 
    815             &                 nseaicevars, nseaiceextr, nitend-nit000+2, & 
    816             &                 dobsini, dobsend, ln_ignmis, .FALSE. ) 
    817  
    818          CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), & 
    819             &                 ln_seaice, ln_nea ) 
     877         nseaicesets = 0 
     878 
     879         IF ( ln_seaicefb ) THEN             ! Feedback file format 
     880 
     881            DO jset = 1, jnumseaicefb 
     882             
     883               nseaicesets = nseaicesets + 1 
     884 
     885               CALL obs_rea_seaice( 0, seaicedata(nseaicesets), 1, & 
     886                  &                 seaicefbfiles(jset:jset), & 
     887                  &                 nseaicevars, nseaiceextr, nitend-nit000+2, & 
     888                  &                 dobsini, dobsend, ln_ignmis, .FALSE. ) 
     889 
     890#if defined key_datetime_out 
     891               IF (lwp) THEN 
     892                  CALL DATE_AND_TIME(datestr,timestr)          
     893                  WRITE(numout,*) 'obs_pre_seaice date_and_time ',datestr,' ',timestr 
     894               ENDIF 
     895#endif 
     896 
     897               CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), & 
     898                  &                 ln_seaice, ln_nea ) 
     899             
     900            ENDDO 
     901 
     902         ELSEIF(ln_grdseaice) THEN         ! gridded seaice data 
     903 
     904            nseaicesets = nseaicesets + 1 
     905 
     906            CALL obs_rea_seaice_grd( grdseaicename, grdseaicefmt, & 
     907               &                     seaicedata(nseaicesets), & 
     908               &                     nseaicevars, nseaiceextr, nitend-nit000+2, & 
     909               &                     dobsini, dobsend ) 
     910 
     911            CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), & 
     912               &                 ln_seaice, ln_nea ) 
     913 
     914         ELSE                              ! Original file format 
     915 
     916            nseaicesets = nseaicesets + 1 
     917 
     918            CALL obs_rea_seaice( 1, seaicedata(nseaicesets), jnumseaice, & 
     919               &                 seaicefiles(1:jnumseaice), & 
     920               &                 nseaicevars, nseaiceextr, nitend-nit000+2, & 
     921               &                 dobsini, dobsend, ln_ignmis, .FALSE. ) 
     922 
     923            CALL obs_pre_seaice( seaicedata(nseaicesets), seaicedatqc(nseaicesets), & 
     924               &                 ln_seaice, ln_nea ) 
     925 
     926         ENDIF 
    820927  
    821928      ENDIF 
    … …  
    9761083 
    9771084      ENDIF 
    978       
     1085 
    9791086   END SUBROUTINE dia_obs_init 
    9801087 
    … …  
    10071114      USE dom_oce, ONLY : &             ! Ocean space and time domain variables 
    10081115         & rdt,           &                        
    1009          & gdept_0,       &              
     1116         & gdept_0,       & 
     1117#if defined key_vvl 
     1118         & gdept_1,       & 
     1119#else 
     1120         & gdept,         & 
     1121#endif                                        
     1122         & ln_zco,        & 
     1123         & ln_zps,        & 
    10101124         & tmask, umask, vmask                             
    10111125      USE phycst, ONLY : &              ! Physical constants 
    … …  
    10651179      IF ( ln_t3d .OR. ln_s3d ) THEN 
    10661180         DO jprofset = 1, nprofsets 
    1067             IF ( ld_enact(jprofset) ) THEN 
    1068                CALL obs_pro_opt( prodatqc(jprofset),                     & 
    1069                   &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
    1070                   &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
    1071                   &              gdept_0, tmask, n1dint, n2dint,         & 
    1072                   &              kdailyavtypes = endailyavtypes ) 
     1181            IF( ln_zco .OR. ln_zps ) THEN 
     1182               IF ( ld_enact(jprofset) ) THEN 
     1183                  CALL obs_pro_opt( prodatqc(jprofset),                     & 
     1184                     &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
     1185                     &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
     1186                     &              gdept_0, tmask, n1dint, n2dint,         & 
     1187                     &              kdailyavtypes = endailyavtypes ) 
     1188               ELSE 
     1189                  CALL obs_pro_opt( prodatqc(jprofset),                     & 
     1190                     &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
     1191                     &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
     1192                     &              gdept_0, tmask, n1dint, n2dint               ) 
     1193               ENDIF 
    10731194            ELSE 
    1074                CALL obs_pro_opt( prodatqc(jprofset),                     & 
    1075                   &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
    1076                   &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
    1077                   &              gdept_0, tmask, n1dint, n2dint               ) 
     1195               IF ( ld_enact(jprofset) ) THEN 
     1196                  CALL obs_pro_sco_opt( prodatqc(jprofset),                 & 
     1197                     &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
     1198                     &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
     1199                     &              fsdept(:,:,:), tmask, n1dint, n2dint,   & 
     1200                     &              kdailyavtypes = endailyavtypes ) 
     1201               ELSE 
     1202                  CALL obs_pro_sco_opt( prodatqc(jprofset),                 & 
     1203                     &              kstp, jpi, jpj, jpk, nit000, idaystp,   & 
     1204                     &              tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal),   & 
     1205                     &              fsdept(:,:,:), tmask, n1dint, n2dint ) 
     1206               ENDIF 
    10781207            ENDIF 
    10791208         END DO 
    … …  
    11031232      ENDIF 
    11041233 
    1105 #if defined key_lim2 || defined key_lim3 
     1234#if defined key_ice_lim || defined key_lim2 || defined key_lim3 
    11061235      IF ( ln_seaice ) THEN 
    11071236         DO jseaiceset = 1, nseaicesets 
    … …  
    11101239               &              tmask(:,:,1), n2dint ) 
    11111240         END DO 
     1241      ENDIF       
     1242#endif 
     1243 
     1244#if defined key_cice 
     1245      IF ( ln_seaice ) THEN 
     1246         DO jseaiceset = 1, nseaicesets 
     1247             CALL obs_seaice_opt( seaicedatqc(jseaiceset),           & 
     1248               &              kstp, jpi, jpj, nit000, naicet(:,:,1), & 
     1249               &              tmask(:,:,1), n2dint ) 
     1250         END DO          
    11121251      ENDIF       
    11131252#endif 
    … …  
    11581297      INTEGER :: jfbini 
    11591298      CHARACTER(LEN=20) :: datestr=" ",timestr=" " 
    1160       CHARACTER(LEN=10) :: cdtmp 
     1299      CHARACTER(LEN=20) :: cdtmp 
    11611300      !----------------------------------------------------------------------- 
    11621301      ! Depending on switches call various observation output routines 
    … …  
    11781317 
    11791318         jprofset = 0 
     1319           
    11801320 
    11811321         ! ENACT insitu data 
    … …  
    12721412         ! Write the AVISO SST data 
    12731413 
    1274          IF ( ln_reysst ) THEN 
     1414         IF ( ln_grdsst ) THEN 
    12751415             
    12761416            jsstset = jsstset + 1 
    1277             CALL obs_wri_sst( 'reynolds', sstdata(jsstset) ) 
     1417            CALL obs_wri_sst( 'grdsst', sstdata(jsstset) ) 
    12781418 
    12791419         ENDIF 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_fbm.F90

    r7363 r7367  
    127127   PRIVATE putvaratt_obfbdata 
    128128 
     129#if defined NETCDF4_DEFLATE    
     130   LOGICAL :: lnetcdf4_deflate_unset = .TRUE. 
     131   INTEGER :: nc4_shuffle = 1 
     132   INTEGER :: nc4_deflate = 1 
     133   INTEGER :: nc4_deflate_level = 6 
     134#endif 
     135 
    129136   !!---------------------------------------------------------------------- 
    130137   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    11011108      CHARACTER(len=ilenlong) :: & 
    11021109         & cdltmp 
     1110      INTEGER :: status   
    11031111 
    11041112      ! Open output filename 
    11051113 
    1106       CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_clobber, idfile ), & 
     1114      ! Test if file exists as cmode option in nf90_create can only be NF90_NOCLOBBER or NF90_64BIT_OFFSET, not both. 
     1115      status = nf90_open( TRIM( cdfilename ), NF90_NOWRITE, idfile ) 
     1116      if (status==0) then 
     1117        CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) 
     1118         write(*,*) "File exists - will not overwrite. Exiting." 
     1119         CALL abort 
     1120      end if 
     1121 
     1122#if defined NETCDF4_DEFLATE    
     1123      CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_netcdf4, idfile ), & 
    11071124         &         cpname, __LINE__ ) 
     1125#else 
     1126      CALL chkerr( nf90_create( TRIM( cdfilename ), & 
     1127         &                      nf90_64bit_offset, & 
     1128         &                      idfile ), & 
     1129         &         cpname, __LINE__ ) 
     1130#endif 
    11081131      CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), & 
    11091132         &         cpname, __LINE__ ) 
    … …  
    11531176      CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, & 
    11541177         &                       idvard ), cpname, __LINE__ ) 
     1178#if defined NETCDF4_DEFLATE 
     1179      CALL nc4deflate( idfile, idvard, cpname, __LINE__ ) 
     1180#endif               
    11551181      CALL putvaratt_obfbdata( idfile, idvard, & 
    11561182         &                     'List of variables in feedback files' ) 
    … …  
    11611187         CALL chkerr( nf90_def_var( idfile, 'ENTRIES', nf90_char, incdim2, & 
    11621188            &                       idaddd ), cpname, __LINE__ ) 
     1189#if defined NETCDF4_DEFLATE 
     1190         CALL nc4deflate( idfile, idaddd, cpname, __LINE__ ) 
     1191#endif               
    11631192         CALL putvaratt_obfbdata( idfile, idaddd,  & 
    11641193            &                     'List of additional entries for each '// & 
    … …  
    11711200         CALL chkerr( nf90_def_var( idfile, 'EXTRA', nf90_char, incdim2, & 
    11721201            &                       idextd ), cpname, __LINE__ ) 
     1202#if defined NETCDF4_DEFLATE 
     1203         CALL nc4deflate( idfile, idextd, cpname, __LINE__ ) 
     1204#endif               
    11731205         CALL putvaratt_obfbdata(  idfile, idextd, & 
    11741206            &                      'List of extra variables' ) 
    … …  
    11801212         &                       nf90_char, incdim2, & 
    11811213         &                       idcdwmo ), cpname, __LINE__ ) 
     1214#if defined NETCDF4_DEFLATE 
     1215      CALL nc4deflate( idfile, idcdwmo, cpname, __LINE__ ) 
     1216#endif               
    11821217      CALL putvaratt_obfbdata(  idfile, idcdwmo, & 
    11831218         &                      'Station identifier' ) 
    … …  
    11871222         &                       nf90_char, incdim2, & 
    11881223         &                       idcdtyp ), cpname, __LINE__ ) 
     1224#if defined NETCDF4_DEFLATE 
     1225      CALL nc4deflate( idfile, idcdtyp, cpname, __LINE__ ) 
     1226#endif               
    11891227      CALL putvaratt_obfbdata(  idfile, idcdtyp, & 
    11901228         &                      'Code instrument type' ) 
    … …  
    11931231         &                       nf90_double, incdim1, & 
    11941232         &                       idplam ), cpname, __LINE__ ) 
     1233#if defined NETCDF4_DEFLATE 
     1234      CALL nc4deflate( idfile, idplam, cpname, __LINE__ ) 
     1235#endif               
    11951236      CALL putvaratt_obfbdata(  idfile, idplam, & 
    11961237         &                      'Longitude', cdunits = 'degrees_east', & 
    … …  
    11991240         &                       nf90_double, incdim1, & 
    12001241         &                       idpphi ), cpname, __LINE__ ) 
     1242#if defined NETCDF4_DEFLATE 
     1243      CALL nc4deflate( idfile, idpphi, cpname, __LINE__ ) 
     1244#endif               
    12011245      CALL putvaratt_obfbdata(  idfile, idpphi, & 
    12021246         &                      'Latitude', cdunits = 'degrees_north', & 
    … …  
    12071251         &                       nf90_double, incdim2, & 
    12081252         &                       idpdep ), cpname, __LINE__ ) 
     1253#if defined NETCDF4_DEFLATE 
     1254      CALL nc4deflate( idfile, idpdep, cpname, __LINE__ ) 
     1255#endif               
    12091256      CALL putvaratt_obfbdata(  idfile, idpdep, & 
    12101257         &                      'Depth', cdunits = 'metre', & 
    … …  
    12161263         &                       nf90_int, incdim2, & 
    12171264         &                       ididqc ), cpname, __LINE__ ) 
     1265#if defined NETCDF4_DEFLATE 
     1266      CALL nc4deflate( idfile, ididqc, cpname, __LINE__ ) 
     1267#endif               
    12181268      CALL putvaratt_obfbdata(  idfile, ididqc, & 
    12191269         &                      'Quality on depth',  & 
    … …  
    12231273         &                       nf90_int, incdim3, & 
    12241274         &                       ididqcf ), cpname, __LINE__ ) 
     1275#if defined NETCDF4_DEFLATE 
     1276      CALL nc4deflate( idfile, ididqcf, cpname, __LINE__ ) 
     1277#endif               
    12251278      CALL putvaratt_obfbdata(  idfile, ididqcf, & 
    12261279         &                      'Quality flags on depth',  & 
    … …  
    12291282         &                       nf90_double, incdim1, & 
    12301283         &                       idptim ), cpname, __LINE__ ) 
     1284#if defined NETCDF4_DEFLATE 
     1285      CALL nc4deflate( idfile, idptim, cpname, __LINE__ ) 
     1286#endif               
    12311287      CALL putvaratt_obfbdata(  idfile, idptim, & 
    12321288         &                      'Julian day', & 
    … …  
    12391295         &                       nf90_char, incdim1, & 
    12401296         &                       idptimr ), cpname, __LINE__ ) 
     1297#if defined NETCDF4_DEFLATE 
     1298      CALL nc4deflate( idfile, idptimr, cpname, __LINE__ ) 
     1299#endif               
    12411300      CALL putvaratt_obfbdata(  idfile, idptimr, & 
    12421301         &                      'Date of reference for julian days ', & 
    … …  
    12461305         &                       nf90_int, incdim1, & 
    12471306         &                       idioqc ), cpname, __LINE__ ) 
     1307#if defined NETCDF4_DEFLATE 
     1308      CALL nc4deflate( idfile, idioqc, cpname, __LINE__ ) 
     1309#endif               
    12481310      CALL putvaratt_obfbdata(  idfile, idioqc, & 
    12491311         &                      'Quality on observation',  & 
    … …  
    12551317         &                       nf90_int, incdim2, & 
    12561318         &                       idioqcf ), cpname, __LINE__ ) 
     1319#if defined NETCDF4_DEFLATE 
     1320      CALL nc4deflate( idfile, idioqcf, cpname, __LINE__ ) 
     1321#endif               
    12571322      CALL putvaratt_obfbdata(  idfile, idioqcf, & 
    12581323         &                      'Quality flags on observation',  & 
    … …  
    12621327         &                       nf90_int, incdim1, & 
    12631328         &                       idipqc ), cpname, __LINE__ ) 
     1329#if defined NETCDF4_DEFLATE 
     1330      CALL nc4deflate( idfile, idipqc, cpname, __LINE__ ) 
     1331#endif               
    12641332      CALL putvaratt_obfbdata(  idfile, idipqc, & 
    12651333         &                      'Quality on position (latitude and longitude)',  & 
    … …  
    12691337         &                       nf90_int, incdim2, & 
    12701338         &                       idipqcf ), cpname, __LINE__ ) 
     1339#if defined NETCDF4_DEFLATE 
     1340      CALL nc4deflate( idfile, idipqcf, cpname, __LINE__ ) 
     1341#endif               
    12711342      CALL putvaratt_obfbdata(  idfile, idipqcf, & 
    12721343         &                      'Quality flags on position',  & 
    … …  
    12761347         &                       nf90_int, incdim1, & 
    12771348         &                       iditqc ), cpname, __LINE__ ) 
     1349#if defined NETCDF4_DEFLATE 
     1350      CALL nc4deflate( idfile, iditqc, cpname, __LINE__ ) 
     1351#endif               
    12781352      CALL putvaratt_obfbdata(  idfile, iditqc, & 
    12791353         &                      'Quality on date and time',  & 
    … …  
    12831357         &                       nf90_int, incdim2, & 
    12841358         &                       iditqcf ), cpname, __LINE__ ) 
     1359#if defined NETCDF4_DEFLATE 
     1360      CALL nc4deflate( idfile, iditqcf, cpname, __LINE__ ) 
     1361#endif               
    12851362      CALL putvaratt_obfbdata(  idfile, iditqcf, & 
    12861363         &                      'Quality flags on date and time',  & 
    … …  
    12901367         &                       nf90_int, incdim1, & 
    12911368         &                       idkindex ), cpname, __LINE__ ) 
     1369#if defined NETCDF4_DEFLATE 
     1370      CALL nc4deflate( idfile, idkindex, cpname, __LINE__ ) 
     1371#endif               
    12921372      CALL putvaratt_obfbdata(  idfile, idkindex, & 
    12931373         &                      'Index in original data file',  & 
    … …  
    13051385            &                       incdim2, idpob(jv) ), & 
    13061386            &         cpname, __LINE__ ) 
     1387#if defined NETCDF4_DEFLATE 
     1388         CALL nc4deflate( idfile, idpob(jv), cpname, __LINE__ ) 
     1389#endif 
     1390 
    13071391         CALL putvaratt_obfbdata(  idfile, idpob(jv), & 
    13081392            &                      fbdata%coblong(jv),  & 
    … …  
    13171401                  &                       incdim2, idpadd(je,jv) ), & 
    13181402                  &         cpname, __LINE__ ) 
     1403#if defined NETCDF4_DEFLATE 
     1404               CALL nc4deflate( idfile, idpadd(je,jv), cpname, __LINE__ ) 
     1405#endif               
    13191406               CALL putvaratt_obfbdata(  idfile, idpadd(je,jv), & 
    13201407                  &                      fbdata%caddlong(je,jv), & 
    13211408                  &                      cdunits =  fbdata%caddunit(je,jv), & 
    13221409                  &                      rfillvalue = fbrmdi ) 
    1323             END DO 
     1410            ENDDO 
    13241411         ENDIF 
    13251412 
    … …  
    13311418            &                       incdim1, idivqc(jv) ), & 
    13321419            &         cpname, __LINE__ ) 
     1420#if defined NETCDF4_DEFLATE 
     1421         CALL nc4deflate( idfile, idivqc(jv), cpname, __LINE__ ) 
     1422#endif               
    13331423         CALL putvaratt_obfbdata(  idfile, idivqc(jv), & 
    13341424            &                      'Quality on '//cdltmp,  & 
    … …  
    13411431            &                       incdim2, idivqcf(jv) ), & 
    13421432            &         cpname, __LINE__ ) 
     1433#if defined NETCDF4_DEFLATE 
     1434         CALL nc4deflate( idfile, idivqcf(jv), cpname, __LINE__ ) 
     1435#endif               
    13431436         CALL putvaratt_obfbdata(  idfile, idivqcf(jv), & 
    13441437            &                      'Quality flags on '//cdltmp,  & 
    … …  
    13511444            &                       incdim2, idivlqc(jv) ), & 
    13521445            &         cpname, __LINE__ ) 
     1446#if defined NETCDF4_DEFLATE 
     1447         CALL nc4deflate( idfile, idivlqc(jv), cpname, __LINE__ ) 
     1448#endif               
    13531449         CALL putvaratt_obfbdata(  idfile, idivlqc(jv), & 
    13541450            &                      'Quality for each level on '//cdltmp,  & 
    … …  
    13621458            &                       incdim3, idivlqcf(jv) ), & 
    13631459            &         cpname, __LINE__ ) 
     1460#if defined NETCDF4_DEFLATE 
     1461         CALL nc4deflate( idfile, idivlqcf(jv), cpname, __LINE__ ) 
     1462#endif               
    13641463         CALL putvaratt_obfbdata(  idfile, idivlqcf(jv), & 
    13651464            &                      'Quality flags for each level on '//& 
    … …  
    13751474               &                       incdim1, idiobsi(jv) ), & 
    13761475               &         cpname, __LINE__ ) 
     1476#if defined NETCDF4_DEFLATE 
     1477            CALL nc4deflate( idfile, idiobsi(jv), cpname, __LINE__ ) 
     1478#endif               
    13771479            CALL putvaratt_obfbdata(  idfile, idiobsi(jv), & 
    13781480               &                      'ORCA grid search I coordinate') 
    … …  
    13811483               &                       incdim1, idiobsj(jv) ), & 
    13821484               &         cpname, __LINE__ ) 
     1485#if defined NETCDF4_DEFLATE 
     1486            CALL nc4deflate( idfile, idiobsj(jv), cpname, __LINE__ ) 
     1487#endif               
    13831488            CALL putvaratt_obfbdata(  idfile, idiobsj(jv), & 
    13841489               &                      'ORCA grid search J coordinate') 
    … …  
    13871492               &                       incdim2, idiobsk(jv) ), & 
    13881493               &         cpname, __LINE__ ) 
     1494#if defined NETCDF4_DEFLATE 
     1495            CALL nc4deflate( idfile, idiobsk(jv), cpname, __LINE__ ) 
     1496#endif               
    13891497            CALL putvaratt_obfbdata(  idfile, idiobsk(jv), & 
    13901498               &                      'ORCA grid search K coordinate') 
    … …  
    13931501            CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_char, incdim1, & 
    13941502               &                       idcgrid(jv) ), cpname, __LINE__ ) 
     1503#if defined NETCDF4_DEFLATE 
     1504            CALL nc4deflate( idfile, idcgrid(jv), cpname, __LINE__ ) 
     1505#endif               
    13951506            CALL putvaratt_obfbdata(  idfile, idcgrid(jv), & 
    13961507               &                      'ORCA grid search grid (T,U,V)') 
    … …  
    14071518               &                       incdim2, idpext(je) ), & 
    14081519               &         cpname, __LINE__ ) 
     1520#if defined NETCDF4_DEFLATE 
     1521            CALL nc4deflate( idfile, idpext(je), cpname, __LINE__ ) 
     1522#endif               
    14091523            CALL putvaratt_obfbdata(  idfile, idpext(je), & 
    14101524               &                      fbdata%cextlong(je),  & 
    … …  
    14131527         END DO 
    14141528      ENDIF 
    1415        
     1529 
    14161530      ! Stop definitions 
    14171531 
    … …  
    19962110   END SUBROUTINE getvaratt_obfbdata 
    19972111 
     2112#if defined NETCDF4_DEFLATE 
     2113   SUBROUTINE nc4deflate( idfile, idvar, cpname, iline ) 
     2114      !!---------------------------------------------------------------------- 
     2115      !!                    ***  ROUTINE nc4deflate  *** 
     2116      !! 
     2117      !! ** Purpose :   Add compression for netCDF4 (if present). 
     2118      !! 
     2119      !! ** Method  :    
     2120      !! 
     2121      !! ** Action  :  
     2122      !! 
     2123      !!---------------------------------------------------------------------- 
     2124      !! * Arguments 
     2125      INTEGER :: & 
     2126         & idfile, &   ! File netcdf id. 
     2127         & idvar,  &   ! Variable netcdf id. 
     2128         & iline       ! Line number. 
     2129      CHARACTER(len=*) :: & 
     2130         & cpname      ! Calling routine name. 
     2131      !! * Local variables 
     2132      CHARACTER(len=128) :: & 
     2133         & cdenv 
     2134       
     2135      IF (lnetcdf4_deflate_unset) THEN 
     2136          
     2137#if ! defined (NOGETENV) 
     2138         CALL getenv('NC4_SHUFFLE',cdenv) 
     2139         IF (cdenv.NE."") THEN 
     2140            READ(cdenv,'(I8)')nc4_shuffle 
     2141         ENDIF 
     2142 
     2143         CALL getenv('NC4_DEFLATE',cdenv) 
     2144         IF (cdenv.NE."") THEN 
     2145            READ(cdenv,'(I8)')nc4_deflate 
     2146         ENDIF 
     2147 
     2148         CALL getenv('NC4_DEFLATE_LEVEL',cdenv) 
     2149         IF (cdenv.NE."") THEN 
     2150            READ(cdenv,'(I8)')nc4_deflate_level 
     2151         ENDIF 
     2152 
     2153#endif 
     2154         lnetcdf4_deflate_unset = .FALSE. 
     2155 
     2156      ENDIF 
     2157          
     2158 
     2159      CALL chkerr (nf90_def_var_deflate( idfile, idvar, & 
     2160         &                               nc4_shuffle, nc4_deflate, & 
     2161         &                               nc4_deflate_level ), & 
     2162         &         cpname, iline ) 
     2163 
     2164   END SUBROUTINE nc4deflate 
     2165#endif 
     2166 
    19982167END MODULE obs_fbm 

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

    r7363 r7367  
    2525      & obs_mpp_max_integer 
    2626   USE phycst, ONLY : &            ! Physical constants 
    27       & rad 
     27      & rad, & 
     28      & ra 
    2829   USE obs_utils, ONLY : &         ! Observation operator utility functions 
    2930      & grt_cir_dis, & 
    … …  
    4142   PUBLIC  obs_grid_setup,      & ! Setup grid searching 
    4243      &    obs_grid_search,     & ! Find i, j on the ORCA grid from lat, lon 
     44      &    obs_grid_locate,     & ! Find the grid points where gridded observations is located. 
    4345      &    obs_grid_deallocate, & ! Deallocate the look up table 
    4446      &    obs_level_search       ! Find level from depth 
    … …  
    163165 
    164166   END SUBROUTINE obs_grid_search 
     167 
     168   SUBROUTINE obs_grid_locate( kobsin, plam, pphi, ptim, kobsi, kobsj, kproc, & 
     169      &                        cdgrid ) 
     170      !!---------------------------------------------------------------------- 
     171      !!                ***  ROUTINE obs_grid_locate *** 
     172      !! 
     173      !! ** Purpose : Find the grid points where gridded observations 
     174      !!              is located  
     175      !! 
     176      !! ** Method  :  
     177      !! 
     178      !! ** Action  :  
     179      !!    
     180      !! History : 
     181      !!  !  2012-05  (K. Mogensen) Original based on obs_grid_search_bruteforce 
     182      !!---------------------------------------------------------------------- 
     183 
     184      !! * Arguments 
     185      INTEGER :: kobsin                     ! Size of the observation arrays 
     186      REAL(KIND=wp), DIMENSION(kobsin), INTENT(IN) :: & 
     187         & plam, &                    ! Longitude of obsrvations  
     188         & pphi, &                    ! Latitude of observations 
     189         & ptim                      ! time of observations 
     190      INTEGER, DIMENSION(kobsin), INTENT(OUT) :: & 
     191         & kobsi, &                 ! I-index of observations  
     192         & kobsj, &                 ! J-index of observations  
     193         & kproc                    ! Processor number of observations 
     194      CHARACTER(LEN=1) :: & 
     195         & cdgrid                   ! Grid to search 
     196      !! * Local declarations 
     197      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & 
     198         & zlam, & 
     199         & zphi, & 
     200         & zmskg 
     201      REAL(KIND=wp), DIMENSION(:), ALLOCATABLE :: & 
     202         & zplam 
     203      INTEGER :: ji 
     204      INTEGER :: jj 
     205      INTEGER :: jo 
     206      INTEGER :: jt 
     207      INTEGER :: itim 
     208      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
     209         & ifound    ! Found observations 
     210 
     211      itim = INT( MAXVAL( ptim ) ) 
     212 
     213      kproc(:) = -1 
     214      kobsi(:) = -1 
     215      kobsj(:) = -1 
     216 
     217      IF(lwp) WRITE(numout,*) "MIN and Maximum of ptime:", MINVAL(ptim), MAXVAL(ptim) 
     218 
     219      ALLOCATE( & 
     220         & zlam(jpi,jpj), & 
     221         & zphi(jpi,jpj), & 
     222         & zplam(kobsin), & 
     223         & zmskg(jpi,jpj), & 
     224         & ifound(jpi,jpj,itim) & 
     225         & ) 
     226 
     227      ifound(:,:,:) = 0 
     228 
     229      IF ( cdgrid == "T" ) THEN 
     230 
     231         zphi(:,:) = gphit(:,:) 
     232         zlam(:,:) = glamt(:,:) 
     233         
     234         zmskg(:,:) = tmask_i(:,:) 
     235          
     236      ELSE 
     237 
     238         CALL ctl_stop("obs_grid_locate: Only T-point grid available")          
     239 
     240      ENDIF 
     241 
     242      !--------------------------------------------------------------------- 
     243      ! Ensure that all observation longtiudes are between 0 and 360 
     244      !--------------------------------------------------------------------- 
     245 
     246      WHERE( zlam(:,:)  <  0.0_wp )   zlam(:,:)  = zlam(:,:)  + 360.0_wp 
     247      WHERE( zlam(:,:)  >  360.0_wp ) zlam(:,:)  = zlam(:,:)  - 360.0_wp 
     248 
     249      zplam(:) = plam(:) 
     250 
     251      WHERE( zplam(:) <  0.0_wp )   zplam(:) = zplam(:) + 360.0_wp 
     252      WHERE( zplam(:) >  360.0_wp ) zplam(:) = zplam(:) - 360.0_wp 
     253 
     254      obsloop: DO jo = 1, kobsin 
     255          
     256         DO jj = nldj, nlej 
     257 
     258            DO ji = nldi, nlei 
     259 
     260               IF( zmskg(ji,jj) == 0.0_wp ) CYCLE 
     261 
     262               ! Accept obs if lat and lon difference btw grid point  
     263               ! is less than 1e-02 deg 
     264 
     265               IF ( ( ABS( zphi(ji,jj) - pphi(jo) ) < 1e-02_wp ) .AND. & 
     266                  & ( ABS( zlam(ji,jj) - zplam(jo) ) < 1e-02_wp ) )  THEN 
     267 
     268                  jt = INT( ptim(jo) ) 
     269 
     270                  IF ( ifound(ji,jj,jt) /= 1 ) THEN 
     271                      
     272                     kobsi(jo) = ji 
     273                     kobsj(jo) = jj 
     274                     kproc(jo) = nproc 
     275                     ifound(ji,jj,jt) = 1 
     276 
     277                  ELSE 
     278                      
     279                     IF (lwp)  WRITE(numout,*) "obs_grid_locate : skip duplicate data (ji, jj, jo):", & 
     280                        &                      ji, jj, jo 
     281                
     282                  ENDIF 
     283 
     284               ENDIF 
     285 
     286            END DO 
     287 
     288         END DO 
     289          
     290      END DO obsloop 
     291 
     292      IF (lwp) THEN 
     293 
     294         WRITE(numout,*) "tmask_i size: ", SUM( tmask_i(:,:) )  
     295          
     296         DO jt = 1, itim 
     297             
     298            WRITE(numout,*) "obs vec size (rec) : (", jt, ")", SUM( ifound(:,:,jt) )  
     299             
     300         END DO 
     301 
     302      ENDIF 
     303          
     304      DEALLOCATE( & 
     305         & zlam, & 
     306         & zphi, & 
     307         & zplam, & 
     308         & zmskg, & 
     309         & ifound & 
     310         & ) 
     311       
     312      CALL obs_mpp_max_integer( kproc, kobsin ) 
     313      CALL obs_mpp_max_integer( kobsi, kobsin ) 
     314      CALL obs_mpp_max_integer( kobsj, kobsin ) 
     315 
     316   END SUBROUTINE obs_grid_locate 
    165317 
    166318#include "obs_grd_bruteforce.h90" 
    … …  
    363515      END DO 
    364516 
    365       if(lwp) WRITE(numout,*) 'obs_grid_lookup do coordinate search using lookup table' 
     517      IF(lwp) WRITE(numout,*) 'obs_grid_lookup do coordinate search using lookup table' 
    366518 
    367519      !----------------------------------------------------------------------- 
    … …  
    685837      IF (ln_grid_search_lookup) THEN 
    686838          
    687          WRITE(numout,*) 'Calling obs_grid_setup' 
     839         IF(lwp) WRITE(numout,*) 'Calling obs_grid_setup' 
    688840          
    689841         IF(lwp) WRITE(numout,*) 
    … …  
    722874            ! initially assume size is as defined (to be fixed) 
    723875             
    724             WRITE(numout,*) 'Reading: ',cfname 
     876            IF(lwp) WRITE(numout,*) 'Reading: ',cfname 
    725877             
    726878            CALL chkerr( nf90_open( TRIM( cfname ), nf90_nowrite, idfile ), & 

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

    r7363 r7367  
    99   !!   obs_pro_opt :    Compute the model counterpart of temperature and 
    1010   !!                    salinity observations from profiles 
     11   !!   obs_pro_sco_opt: Compute the model counterpart of temperature and 
     12   !!                    salinity observations from profiles in generalised 
     13   !!                    vertical coordinates 
    1114   !!   obs_sla_opt :    Compute the model counterpart of sea level anomaly 
    1215   !!                    observations 
    … …  
    3740   USE dom_oce,       ONLY : & 
    3841      & glamt, glamu, glamv, & 
    39       & gphit, gphiu, gphiv 
     42      & gphit, gphiu, gphiv, & 
     43#if defined key_vvl 
     44      & gdept_1 
     45#else 
     46      & gdept 
     47#endif  
    4048   USE lib_mpp,       ONLY : & 
    4149      & ctl_warn, ctl_stop 
     50   USE obs_grid,      ONLY : & 
     51      & obs_level_search     
    4252 
    4353   IMPLICIT NONE 
    … …  
    4757 
    4858   PUBLIC obs_pro_opt, &  ! Compute the model counterpart of profile observations 
     59      &   obs_pro_sco_opt, &  ! Compute the model counterpart of profile observations 
     60                              ! in generalised vertical coordinates 
    4961      &   obs_sla_opt, &  ! Compute the model counterpart of SLA observations 
    5062      &   obs_sst_opt, &  ! Compute the model counterpart of SST observations 
    … …  
    6173   !!---------------------------------------------------------------------- 
    6274 
     75!! * Substitutions 
     76#  include "domzgr_substitute.h90" 
    6377CONTAINS 
    6478 
    … …  
    449463   END SUBROUTINE obs_pro_opt 
    450464 
     465   SUBROUTINE obs_pro_sco_opt( prodatqc, kt, kpi, kpj, kpk, kit000, kdaystp, & 
     466      &                    ptn, psn, pgdept, ptmask, k1dint, k2dint, & 
     467      &                    kdailyavtypes ) 
     468      !!----------------------------------------------------------------------- 
     469      !! 
     470      !!                     ***  ROUTINE obs_pro_opt  *** 
     471      !! 
     472      !! ** Purpose : Compute the model counterpart of profiles 
     473      !!              data by interpolating from the model grid to the  
     474      !!              observation point. Generalised vertical coordinate version 
     475      !! 
     476      !! ** Method  : Linearly interpolate to each observation point using  
     477      !!              the model values at the corners of the surrounding grid box. 
     478      !! 
     479      !!          First, model values on the model grid are interoplated verticaly to the 
     480      !!          Depths of the profile observations.  Two vertical interpolation schemes are 
     481      !!         available: 
     482      !!        - linear       (k1dint = 0) 
     483      !!        - Cubic spline (k1dint = 1)    
     484      !! 
     485      !! 
     486      !!         Secondly the interpolated values are interpolated horizontaly to the  
     487      !!         obs (lon, lat) point. 
     488      !!         Several horizontal interpolation schemes are available: 
     489      !!        - distance-weighted (great circle) (k2dint = 0) 
     490      !!        - distance-weighted (small angle)  (k2dint = 1) 
     491      !!        - bilinear (geographical grid)     (k2dint = 2) 
     492      !!        - bilinear (quadrilateral grid)    (k2dint = 3) 
     493      !!        - polynomial (quadrilateral grid)  (k2dint = 4) 
     494      !! 
     495      !!    For the cubic spline the 2nd derivative of the interpolating  
     496      !!    polynomial is computed before entering the vertical interpolation  
     497      !!    routine. 
     498      !! 
     499      !!    For ENACT moored buoy data (e.g., TAO), the model equivalent is 
     500      !!    a daily mean model temperature field. So, we first compute 
     501      !!    the mean, then interpolate only at the end of the day. 
     502      !! 
     503      !!    This is the procedure to be used with generalised vertical model  
     504      !!    coordinates (ie s-coordinates. It is ~4x slower than the equivalent 
     505      !!    horizontal then vertical interpolation algorithm, but can deal with situations 
     506      !!    where the model levels are not flat. 
     507      !!    ONLY PERFORMED if ln_sco=.TRUE.  
     508      !!       
     509      !!    Note: the in situ temperature observations must be converted 
     510      !!    to potential temperature (the model variable) prior to 
     511      !!    assimilation.  
     512      !!?????????????????????????????????????????????????????????????? 
     513      !!    INCLUDE POTENTIAL TEMP -> IN SITU TEMP IN OBS OPERATOR??? 
     514      !!?????????????????????????????????????????????????????????????? 
     515      !! 
     516      !! ** Action  : 
     517      !! 
     518      !! History : 
     519      !!      ! 97-11 (A. Weaver, S. Ricci, N. Daget) 
     520      !!      ! 06-03 (G. Smith) NEMOVAR migration 
     521      !!      ! 06-10 (A. Weaver) Cleanup 
     522      !!      ! 07-01 (K. Mogensen) Merge of temperature and salinity 
     523      !!      ! 07-03 (K. Mogensen) General handling of profiles 
     524      !!      ! 2012-11 (J. While) Adapted to handle a grid with varying depth levels 
     525      !!----------------------------------------------------------------------- 
     526   
     527      !! * Modules used 
     528      USE obs_profiles_def ! Definition of storage space for profile obs. 
     529      USE dom_oce,  ONLY : & 
     530#if defined key_vvl  
     531      gdepw_1 
     532#else 
     533      gdepw 
     534#endif 
     535       
     536      IMPLICIT NONE 
     537 
     538      !! * Arguments 
     539      TYPE(obs_prof), INTENT(INOUT) :: prodatqc  ! Subset of profile data not failing screening 
     540      INTEGER, INTENT(IN) :: kt        ! Time step 
     541      INTEGER, INTENT(IN) :: kpi       ! Model grid parameters 
     542      INTEGER, INTENT(IN) :: kpj 
     543      INTEGER, INTENT(IN) :: kpk 
     544      INTEGER, INTENT(IN) :: kit000    ! Number of the first time step  
     545                                       !   (kit000-1 = restart time) 
     546      INTEGER, INTENT(IN) :: k1dint    ! Vertical interpolation type (see header) 
     547      INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
     548      INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day                     
     549      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
     550         & ptn,    &    ! Model temperature field 
     551         & psn,    &    ! Model salinity field 
     552         & ptmask       ! Land-sea mask 
     553      REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,jpj,kpk) :: & 
     554         & pgdept       ! Model array of depth levels 
     555      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
     556         & kdailyavtypes! Types for daily averages 
     557      !! * Local declarations 
     558      INTEGER ::   ji 
     559      INTEGER ::   jj 
     560      INTEGER ::   jk 
     561      INTEGER ::   iico, ijco 
     562      INTEGER ::   jobs 
     563      INTEGER ::   inrc 
     564      INTEGER ::   ipro 
     565      INTEGER ::   idayend 
     566      INTEGER ::   ista 
     567      INTEGER ::   iend 
     568      INTEGER ::   iobs 
     569      INTEGER ::   iin, ijn, ikn, ik   !looping indicies over interpolation nodes 
     570      INTEGER, DIMENSION(imaxavtypes) :: & 
     571         & idailyavtypes 
     572      REAL(KIND=wp) :: zlam 
     573      REAL(KIND=wp) :: zphi 
     574      REAL(KIND=wp) :: zdaystp 
     575      REAL(KIND=wp), DIMENSION(kpk) :: & 
     576         & zobsmask, & 
     577         & zobsk,    & 
     578         & zobs2k 
     579      REAL(KIND=wp), DIMENSION(2,2,1) :: & 
     580         & zweig, & 
     581         & l_zweig 
     582      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & 
     583         & zmask, & 
     584         & zintt, & 
     585         & zints, & 
     586         & zinmt, & 
     587         & zinms 
     588      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
     589         & zglam, & 
     590         & zgphi 
     591      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
     592         & igrdi, & 
     593         & igrdj 
     594      INTEGER :: & 
     595         & inum_obs    
     596      REAL(KIND=wp), DIMENSION(1) :: zmsk_1    
     597      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: interp_corner    
     598      INTEGER, ALLOCATABLE, DIMENSION(:) ::           v_indic    
     599 
     600      !------------------------------------------------------------------------ 
     601      ! Local initialization  
     602      !------------------------------------------------------------------------ 
     603      ! ... Record and data counters 
     604      inrc = kt - kit000 + 2 
     605      ipro = prodatqc%npstp(inrc) 
     606  
     607      ! Daily average types 
     608      IF ( PRESENT(kdailyavtypes) ) THEN 
     609         idailyavtypes(:) = kdailyavtypes(:) 
     610      ELSE 
     611         idailyavtypes(:) = -1 
     612      ENDIF 
     613 
     614      ! Initialize daily mean for first timestep 
     615      idayend = MOD( kt - kit000 + 1, kdaystp ) 
     616 
     617      ! Added kt == 0 test to catch restart case  
     618      IF ( idayend == 1 .OR. kt == 0) THEN 
     619          
     620         IF (lwp) WRITE(numout,*) 'Reset prodatqc%vdmean on time-step: ',kt 
     621         DO jk = 1, jpk 
     622            DO jj = 1, jpj 
     623               DO ji = 1, jpi 
     624                  prodatqc%vdmean(ji,jj,jk,1) = 0.0 
     625                  prodatqc%vdmean(ji,jj,jk,2) = 0.0 
     626               END DO 
     627            END DO 
     628         END DO 
     629       
     630      ENDIF 
     631       
     632      DO jk = 1, jpk 
     633         DO jj = 1, jpj 
     634            DO ji = 1, jpi 
     635               ! Increment the temperature field for computing daily mean 
     636               prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
     637               &                        + ptn(ji,jj,jk) 
     638               ! Increment the salinity field for computing daily mean 
     639               prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
     640               &                        + psn(ji,jj,jk) 
     641            END DO 
     642         END DO 
     643      END DO 
     644    
     645      ! Compute the daily mean at the end of day 
     646      zdaystp = 1.0 / REAL( kdaystp ) 
     647      IF ( idayend == 0 ) THEN 
     648         DO jk = 1, jpk 
     649            DO jj = 1, jpj 
     650               DO ji = 1, jpi 
     651                  prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & 
     652                  &                        * zdaystp 
     653                  prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & 
     654                  &                           * zdaystp 
     655               END DO 
     656            END DO 
     657         END DO 
     658      ENDIF 
     659       
     660      ! Return if no observations 
     661      IF ( ipro == 0 ) RETURN 
     662 
     663      ! Get the data for interpolation 
     664      ALLOCATE( & 
     665      & igrdi(2,2,ipro),      & 
     666      & igrdj(2,2,ipro),      & 
     667      & zglam(2,2,ipro),      & 
     668      & zgphi(2,2,ipro),      & 
     669      & zmask(2,2,kpk,ipro),  & 
     670      & zintt(2,2,kpk,ipro),  & 
     671      & zints(2,2,kpk,ipro)   & 
     672      & ) 
     673 
     674      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
     675         iobs = jobs - prodatqc%nprofup 
     676         igrdi(1,1,iobs) = prodatqc%mi(jobs,1)-1 
     677         igrdj(1,1,iobs) = prodatqc%mj(jobs,1)-1 
     678         igrdi(1,2,iobs) = prodatqc%mi(jobs,1)-1 
     679         igrdj(1,2,iobs) = prodatqc%mj(jobs,1) 
     680         igrdi(2,1,iobs) = prodatqc%mi(jobs,1) 
     681         igrdj(2,1,iobs) = prodatqc%mj(jobs,1)-1 
     682         igrdi(2,2,iobs) = prodatqc%mi(jobs,1) 
     683         igrdj(2,2,iobs) = prodatqc%mj(jobs,1) 
     684      END DO 
     685 
     686      CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, glamt, zglam ) 
     687      CALL obs_int_comm_2d( 2, 2, ipro, igrdi, igrdj, gphit, zgphi ) 
     688      CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptmask,zmask ) 
     689      CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, ptn,   zintt ) 
     690      CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, psn,   zints ) 
     691 
     692      ! At the end of the day also get interpolated means 
     693      IF ( idayend == 0 ) THEN 
     694 
     695         ALLOCATE( & 
     696         & zinmt(2,2,kpk,ipro),  & 
     697         & zinms(2,2,kpk,ipro)   & 
     698         & ) 
     699 
     700         CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, & 
     701         &                  prodatqc%vdmean(:,:,:,1), zinmt ) 
     702         CALL obs_int_comm_3d( 2, 2, ipro, kpk, igrdi, igrdj, & 
     703         &                  prodatqc%vdmean(:,:,:,2), zinms ) 
     704 
     705      ENDIF 
     706 
     707      DO jobs = prodatqc%nprofup + 1, prodatqc%nprofup + ipro 
     708    
     709         iobs = jobs - prodatqc%nprofup 
     710    
     711         IF ( kt /= prodatqc%mstp(jobs) ) THEN 
     712             
     713            IF(lwp) THEN 
     714               WRITE(numout,*) 
     715               WRITE(numout,*) ' E R R O R : Observation',              & 
     716                  &            ' time step is not consistent with the', & 
     717                  &            ' model time step' 
     718               WRITE(numout,*) ' =========' 
     719               WRITE(numout,*) 
     720               WRITE(numout,*) ' Record  = ', jobs,                    & 
     721                  &            ' kt      = ', kt,                      & 
     722                  &            ' mstp    = ', prodatqc%mstp(jobs), & 
     723                  &            ' ntyp    = ', prodatqc%ntyp(jobs) 
     724            ENDIF 
     725            CALL ctl_stop( 'obs_pro_opt', 'Inconsistent time' ) 
     726         ENDIF 
     727          
     728         zlam = prodatqc%rlam(jobs) 
     729         zphi = prodatqc%rphi(jobs) 
     730         iico = prodatqc%mi(jobs,1) 
     731         ijco = prodatqc%mj(jobs,1) 
     732          
     733         ! Horizontal weights 
     734         ! Only calculated once, for both T and S. 
     735         ! Masked values are calculated later.  
     736 
     737         IF ( ( prodatqc%npvend(jobs,1) > 0 ) .OR. & 
     738         & ( prodatqc%npvend(jobs,2) > 0 ) ) THEN 
     739 
     740            CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,     & 
     741            &                   zglam(:,:,iobs), zgphi(:,:,iobs), & 
     742            &                   zmask(:,:,1,iobs), zweig, zmsk_1 ) 
     743 
     744         ENDIF 
     745         
     746         !IF zmsk_1 = 0; then ob is on land 
     747         IF (zmsk_1(1) < 0.1) THEN 
     748            WRITE(numout,*) 'WARNING (obs_oper) :- profile found within landmask' 
     749   
     750         ELSE  
     751             
     752            ! Temperature 
     753             
     754            IF ( prodatqc%npvend(jobs,1) > 0 ) THEN  
     755    
     756               zobsk(:) = obfillflt 
     757    
     758               IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
     759    
     760                  IF ( idayend == 0 )  THEN 
     761                   
     762                     ! Daily averaged moored buoy (MRB) data 
     763                   
     764                     !verticaly interoplate all 4 corners 
     765                     ista = prodatqc%npvsta(jobs,1) 
     766                     iend = prodatqc%npvend(jobs,1) 
     767                     inum_obs = iend - ista + 1 
     768                     ALLOCATE(interp_corner(2,2,inum_obs),v_indic(inum_obs)) 
     769      
     770                     DO iin=1,0,-1    !NOTE the DO loops are decreasing. 
     771                        DO ijn=1,0,-1 !This is because iico and ijco  
     772                                      !are for the top right hand  
     773                                      !corner of the enclosing grid square 
     774           
     775                           IF ( k1dint == 1 ) THEN 
     776                              CALL obs_int_z1d_spl( kpk, & 
     777                              &     prodatqc%vdmean(iico-iin,ijco-ijn,:,1), & 
     778                              &     zobs2k, pgdept(iico-iin,ijco-ijn,:), & 
     779                              &     ptmask(iico-iin,ijco-ijn,: )) 
     780                           ENDIF 
     781       
     782                           CALL obs_level_search(kpk, & 
     783                           &    fsdept(iico-iin,ijco-ijn,:), & 
     784                           &    inum_obs, prodatqc%var(1)%vdep(ista:iend), & 
     785                           &    v_indic) 
     786                           CALL obs_int_z1d(kpk, v_indic, k1dint, inum_obs, & 
     787                           &    prodatqc%var(1)%vdep(ista:iend), & 
     788                           &    prodatqc%vdmean(iico-iin,ijco-ijn,:,1), & 
     789                           &    zobs2k, interp_corner(2-iin,2-ijn,:), & 
     790                           &    pgdept(iico-iin,ijco-ijn,:), & 
     791                           &    ptmask(iico-iin,ijco-ijn,: )) 
     792       
     793                        ENDDO 
     794                     ENDDO 
     795                   
     796                   
     797                  ELSE 
     798                
     799                     CALL ctl_stop( ' A nonzero' //     & 
     800                     &           ' number of profile T BUOY data should' // & 
     801                     &           ' only occur at the end of a given day' ) 
     802    
     803                  ENDIF 
     804         
     805               ELSE  
     806                
     807                  ! Point data 
     808     
     809                  !verticaly interoplate all 4 corners 
     810                  ista = prodatqc%npvsta(jobs,1) 
     811                  iend = prodatqc%npvend(jobs,1) 
     812                  inum_obs = iend - ista + 1 
     813                  ALLOCATE(interp_corner(2,2,inum_obs), v_indic(inum_obs)) 
     814                  DO iin=1,0,-1     !note: the DO loops are decreasing. 
     815                     DO ijn=1,0,-1  !This is because iico and ijco are  
     816                                    !for the top right hand  
     817                                    !corner of the enclosing grid square 
     818                        IF ( k1dint == 1 ) THEN 
     819                           CALL obs_int_z1d_spl( kpk, & 
     820                           &    ptn(iico-iin,ijco-ijn,:),& 
     821                           &    zobs2k, pgdept(iico-iin,ijco-ijn,:), & 
     822                           &    ptmask(iico-iin,ijco-ijn,: )) 
     823  
     824                        ENDIF 
     825       
     826                        CALL obs_level_search(kpk, & 
     827                         &        fsdept(iico-iin,ijco-ijn,:),& 
     828                         &        inum_obs, prodatqc%var(1)%vdep(ista:iend), & 
     829                         &         v_indic) 
     830                        CALL obs_int_z1d(kpk, v_indic, k1dint, inum_obs,     & 
     831                         &          prodatqc%var(1)%vdep(ista:iend),     & 
     832                         &          ptn(iico-iin,ijco-ijn,:),            & 
     833                         &          zobs2k,interp_corner(2-iin,2-ijn,:), & 
     834                         &          pgdept(iico-iin,ijco-ijn,:),         & 
     835                         &          ptmask(iico-iin,ijco-ijn,: ) )      
     836         
     837                     ENDDO 
     838                  ENDDO 
     839             
     840               ENDIF 
     841       
     842               !------------------------------------------------------------- 
     843               ! Compute the horizontal interpolation for every profile level 
     844               !------------------------------------------------------------- 
     845             
     846               DO ikn=1,inum_obs 
     847                  iend=ista+ikn-1 
     848   
     849                  !This code forces the horrizontal weights to be  
     850                  !zero IF the observation is below the bottom of the  
     851                  !corners of the interpolation nodes, Or if it is in  
     852                  !the mask. This is important for observations are near  
     853                  !steep bathymetry 
     854                  DO iin=1,0,-1 
     855                     DO ijn=1,0,-1 
     856     
     857                        depth_loop1: DO ik=kpk,2,-1 
     858                           IF(ptmask(iico-iin,ijco-ijn,ik-1 ) > 0.9 )THEN   
     859                            
     860                              l_zweig(2-iin,2-ijn,1) = &  
     861                           &  zweig(2-iin,2-ijn,1) *   & 
     862                           &  MAX( SIGN(1._wp,(fsdepw(iico-iin,ijco-ijn,ik) ) & 
     863                           &  - prodatqc%var(1)%vdep(iend)),0._wp) 
     864                            
     865                              EXIT depth_loop1 
     866                           ENDIF 
     867                        ENDDO depth_loop1 
     868     
     869                     ENDDO 
     870                  ENDDO 
     871   
     872                  CALL obs_int_h2d( 1, 1, l_zweig, interp_corner(:,:,ikn), & 
     873                  &          prodatqc%var(1)%vmod(iend:iend) ) 
     874 
     875               ENDDO 
     876 
     877 
     878               DEALLOCATE(interp_corner,v_indic) 
     879          
     880            ENDIF 
     881       
     882 
     883            ! Salinity  
     884          
     885            IF ( prodatqc%npvend(jobs,2) > 0 ) THEN 
     886    
     887               zobsk(:) = obfillflt 
     888    
     889               IF ( ANY (idailyavtypes(:) == prodatqc%ntyp(jobs)) ) THEN 
     890    
     891                  IF ( idayend == 0 )  THEN 
     892                   
     893                     ! Daily averaged moored buoy (MRB) data 
     894                   
     895                     !verticaly interoplate all 4 corners 
     896                     ista = prodatqc%npvsta(jobs,2) 
     897                     iend = prodatqc%npvend(jobs,2) 
     898                     inum_obs=iend - ista + 1 
     899                     ALLOCATE(interp_corner(2,2,inum_obs),v_indic(inum_obs)) 
     900      
     901                     DO iin=1,0,-1    !NOTE the DO loops are decreasing. 
     902                        DO ijn=1,0,-1 !This is because iico and ijco  
     903                                      !are for the top right hand  
     904                                      !corner of the enclosing grid square 
     905           
     906                           IF ( k1dint == 1 ) THEN 
     907                              CALL obs_int_z1d_spl( kpk, & 
     908                              &     prodatqc%vdmean(iico-iin,ijco-ijn,:,2), & 
     909                              &     zobs2k, pgdept(iico-iin,ijco-ijn,:), & 
     910                              &     ptmask(iico-iin,ijco-ijn,: )) 
     911                           ENDIF 
     912       
     913                           CALL obs_level_search(kpk, & 
     914                           &    fsdept(iico-iin,ijco-ijn,:), & 
     915                           &    inum_obs, prodatqc%var(2)%vdep(ista:iend), & 
     916                           &    v_indic) 
     917                           CALL obs_int_z1d(kpk, v_indic, k1dint, inum_obs, & 
     918                           &    prodatqc%var(2)%vdep(ista:iend), & 
     919                           &    prodatqc%vdmean(iico-iin,ijco-ijn,:,2), & 
     920                           &    zobs2k, interp_corner(2-iin,2-ijn,:), & 
     921                           &    pgdept(iico-iin,ijco-ijn,:), & 
     922                           &    ptmask(iico-iin,ijco-ijn,: )) 
     923       
     924                        END DO 
     925                     END DO 
     926                   
     927                   
     928                  ELSE 
     929                
     930                     CALL ctl_stop( ' A nonzero' //     & 
     931                        &           ' number of profile S BUOY data should' // & 
     932                        &           ' only occur at the end of a given day' ) 
     933    
     934                  ENDIF 
     935         
     936               ELSE  
     937                
     938                  ! Point data 
     939     
     940                  !verticaly interoplate all 4 corners 
     941                  ista = prodatqc%npvsta(jobs,2) 
     942                  iend = prodatqc%npvend(jobs,2) 
     943                  inum_obs=iend - ista + 1 
     944                  ALLOCATE(interp_corner(2,2,inum_obs), v_indic(inum_obs)) 
     945                  DO iin=1,0,-1     !note: the DO loops are decreasing. 
     946                     DO ijn=1,0,-1  !This is because iico and ijco are  
     947                                    !for the top right hand  
     948                                    !corner of the enclosing grid square 
     949                        IF ( k1dint == 1 ) THEN 
     950                           CALL obs_int_z1d_spl( kpk, & 
     951                           &    psn(iico-iin,ijco-ijn,:),& 
     952                           &    zobs2k, pgdept(iico-iin,ijco-ijn,:), & 
     953                           &    ptmask(iico-iin,ijco-ijn,: )) 
     954  
     955                        ENDIF 
     956       
     957                        CALL obs_level_search(kpk, & 
     958                         &        fsdept(iico-iin,ijco-ijn,:),& 
     959                         &        inum_obs, prodatqc%var(2)%vdep(ista:iend), & 
     960                         &         v_indic) 
     961                        CALL obs_int_z1d(kpk, v_indic, k1dint, inum_obs,     & 
     962                         &          prodatqc%var(2)%vdep(ista:iend),     & 
     963                         &          psn(iico-iin,ijco-ijn,:),            & 
     964                         &          zobs2k,interp_corner(2-iin,2-ijn,:), & 
     965                         &          pgdept(iico-iin,ijco-ijn,:),         & 
     966                         &          ptmask(iico-iin,ijco-ijn,: ) )      
     967         
     968                     END DO 
     969                  END DO 
     970             
     971               ENDIF 
     972       
     973               !------------------------------------------------------------- 
     974               ! Compute the horizontal interpolation for every profile level 
     975               !------------------------------------------------------------- 
     976             
     977               DO ikn=1,inum_obs 
     978                  iend=ista+ikn-1 
     979       
     980                  !This code forces the horrizontal weights to be  
     981                  !zero IF the observation is below the bottom of the  
     982                  !corners of the interpolation nodes, Or if it is in  
     983                  !the mask. This is important for observations are near  
     984                  !steep bathymetry 
     985                  DO iin=1,0,-1 
     986                     DO ijn=1,0,-1 
     987        
     988                        depth_loop2: DO ik = kpk,2,-1 
     989                           IF(ptmask(iico-iin,ijco-ijn,ik-1 ) > 0.9 )THEN   
     990                                  
     991                              l_zweig(2-iin,2-ijn,1) = &  
     992                           &  zweig(2-iin,2-ijn,1) *   & 
     993                           &  MAX( SIGN(1._wp,(fsdepw(iico-iin,ijco-ijn,ik) ) & 
     994                           &  - prodatqc%var(2)%vdep(iend)),0._wp) 
     995                                  
     996                              EXIT depth_loop2 
     997                           ENDIF 
     998                        END DO depth_loop2 
     999        
     1000                     END DO 
     1001                  END DO 
     1002       
     1003                  CALL obs_int_h2d( 1, 1, l_zweig, interp_corner(:,:,ikn), & 
     1004                  &          prodatqc%var(2)%vmod(iend:iend) ) 
     1005       
     1006               ENDDO 
     1007       
     1008       
     1009               DEALLOCATE(interp_corner,v_indic) 
     1010             
     1011            ENDIF 
     1012          
     1013         ENDIF 
     1014          
     1015      END DO 
     1016     
     1017      ! Deallocate the data for interpolation 
     1018      DEALLOCATE( & 
     1019         & igrdi, & 
     1020         & igrdj, & 
     1021         & zglam, & 
     1022         & zgphi, & 
     1023         & zmask, & 
     1024         & zintt, & 
     1025         & zints  & 
     1026         & ) 
     1027      ! At the end of the day also get interpolated means 
     1028      IF ( idayend == 0 ) THEN 
     1029         DEALLOCATE( & 
     1030            & zinmt,  & 
     1031            & zinms   & 
     1032            & ) 
     1033      ENDIF 
     1034    
     1035      prodatqc%nprofup = prodatqc%nprofup + ipro  
     1036       
     1037   END SUBROUTINE obs_pro_sco_opt 
     1038 
    4511039   SUBROUTINE obs_sla_opt( sladatqc, kt, kpi, kpj, kit000, & 
    4521040      &                    psshn, psshmask, k2dint ) 
    … …  
    11841772            CALL obs_int_h2d_init( kpk, kpk, k2dint, zlam, zphi,     & 
    11851773               &                   zglamv(:,:,iobs), zgphiv(:,:,iobs), & 
    1186                &                   zvmask(:,:,:,iobs), zweigv, zobsmasku ) 
     1774               &                   zvmask(:,:,:,iobs), zweigv, zobsmaskv ) 
    11871775 
    11881776         ENDIF 

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

    r7363 r7367  
    2727   USE obs_inter_sup      ! Interpolation support 
    2828   USE obs_oper           ! Observation operators 
     29#if defined key_bdy          
     30   USE bdy_oce, ONLY : &        ! Boundary information   
     31      idx_bdy, nb_bdy  
     32#endif  
    2933   USE lib_mpp, ONLY : & 
    3034      & ctl_warn, ctl_stop 
    … …  
    4347      & calc_month_len     ! Calculate the number of days in the months of a year   
    4448 
     49   LOGICAL, PUBLIC :: ln_bound_reject  !: Remove obs near open boundaries 
     50    
    4551   !!---------------------------------------------------------------------- 
    4652   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    4753   !! $Id$ 
    4854   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    49    !!---------------------------------------------------------------------- 
    50  
     55   !!----------------------------------------------------------------------  
     56 
     57!! * Substitutions 
     58#  include "domzgr_substitute.h90"  
    5159CONTAINS 
    5260 
    … …  
    7684         & gphit,   & 
    7785         & gdept_0, & 
     86#if defined key_vvl 
     87         & gdepw_1, & 
     88    & gdept_1, & 
     89#else 
     90         & gdepw,   & 
     91    & gdept,   & 
     92#endif          
    7893         & tmask,   & 
     94    & ln_zco,  & 
     95    & ln_zps,  & 
    7996         & nproc 
    8097      !! * Arguments 
    … …  
    101118      INTEGER :: inlatobs      !  - close to land (temperature) 
    102119      INTEGER :: inlasobs      !  - close to land (salinity) 
     120      INTEGER :: ibdytobs      !  - boundary (temperature)  
     121      INTEGER :: ibdysobs      !  - boundary (salinity)        
    103122      INTEGER :: igrdobs       !  - fail the grid search 
    104123                               ! Global counters for observations that 
    … …  
    110129      INTEGER :: inlatobsmpp   !  - close to land (temperature) 
    111130      INTEGER :: inlasobsmpp   !  - close to land (salinity) 
     131      INTEGER :: ibdytobsmpp   !  - boundary (temperature)  
     132      INTEGER :: ibdysobsmpp   !  - boundary (salinity)        
    112133      INTEGER :: igrdobsmpp    !  - fail the grid search 
    113134      TYPE(obs_prof_valid) ::  llvalid     ! Profile selection  
    … …  
    140161      inlatobs = 0 
    141162      inlasobs = 0 
     163      ibdytobs = 0  
     164      ibdysobs = 0  
    142165 
    143166      ! ----------------------------------------------------------------------- 
    … …  
    196219         &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    197220         &                 iosdtobs,              ilantobs,             & 
    198          &                 inlatobs,              ld_nea                ) 
     221         &                 inlatobs,              ld_nea,               &  
     222         &                 ibdytobs,              ln_bound_reject       )  
    199223 
    200224      CALL obs_mpp_sum_integer( iosdtobs, iosdtobsmpp ) 
    201225      CALL obs_mpp_sum_integer( ilantobs, ilantobsmpp ) 
    202226      CALL obs_mpp_sum_integer( inlatobs, inlatobsmpp ) 
     227      CALL obs_mpp_sum_integer( ibdytobs, ibdytobsmpp )  
    203228 
    204229      ! Salinity 
    … …  
    216241         &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    217242         &                 iosdsobs,              ilansobs,             & 
    218          &                 inlasobs,              ld_nea                ) 
     243         &                 inlasobs,              ld_nea,               &  
     244         &                 ibdysobs,              ln_bound_reject       )  
    219245 
    220246      CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    221247      CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    222248      CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
    223  
     249      CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp )  
     250       
    224251      ! ----------------------------------------------------------------------- 
    225252      ! Copy useful data from the profdata data structure to 
    … …  
    278305               &            inlatobsmpp 
    279306         ENDIF 
     307         WRITE(numout,*) ' Remaining T data near open boundary (removed) = ',&  
     308               &            ibdytobsmpp  
    280309         WRITE(numout,*) ' T data accepted                             = ', & 
    281310            &            prodatqc%nvprotmpp(1) 
    … …  
    291320               &            inlasobsmpp 
    292321         ENDIF 
     322         WRITE(numout,*) ' Remaining S data near open boundary (removed) = ',&  
     323               &            ibdysobsmpp  
    293324         WRITE(numout,*) ' S data accepted                             = ', & 
    294325            &            prodatqc%nvprotmpp(2) 
    … …  
    379410      INTEGER :: inlasobs     !  - close to land 
    380411      INTEGER :: igrdobs      !  - fail the grid search 
     412      INTEGER :: ibdysobs     !  - close to open boundary        
    381413                              ! Global counters for observations that 
    382414      INTEGER :: iotdobsmpp     !  - outside time domain 
    … …  
    385417      INTEGER :: inlasobsmpp    !  - close to land 
    386418      INTEGER :: igrdobsmpp     !  - fail the grid search 
     419      INTEGER :: ibdysobsmpp    !  - close to open boundary        
    387420      LOGICAL, DIMENSION(:), ALLOCATABLE :: &  
    388421         & llvalid            ! SLA data selection 
    … …  
    390423      INTEGER :: jstp         ! Time loop variable 
    391424      INTEGER :: inrc         ! Time index variable 
     425      INTEGER :: irec         ! Record index 
    392426 
    393427      IF(lwp) WRITE(numout,*)'obs_pre_sla : Preparing the SLA observations...' 
    … …  
    409443      ilansobs = 0 
    410444      inlasobs = 0 
     445      ibdysobs = 0 
    411446 
    412447      ! ----------------------------------------------------------------------- 
    … …  
    442477         &                 tmask(:,:,1), sladata%nqc,  & 
    443478         &                 iosdsobs,     ilansobs,     & 
    444          &                 inlasobs,     ld_nea        ) 
     479         &                 inlasobs,     ld_nea,       &  
     480         &                 ibdysobs,     ln_bound_reject       )  
    445481 
    446482      CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    447483      CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    448484      CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
     485      CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp )        
    449486 
    450487      ! ----------------------------------------------------------------------- 
    … …  
    495532               &            inlasobsmpp 
    496533         ENDIF 
     534         WRITE(numout,*) ' Remaining SLA data near open boundary (removed) = ', &  
     535            &            ibdysobsmpp           
    497536         WRITE(numout,*) ' SLA data accepted                             = ', & 
    498537            &            sladatqc%nsurfmpp 
    … …  
    520559      ENDIF 
    521560 
     561      !--------------------------------------------------------- 
     562      ! Record handling 
     563      !--------------------------------------------------------- 
     564 
     565      ! First count the number of records 
     566 
     567      sladatqc%nrec = 0 
     568      DO jstp = nit000 - 1, nitend 
     569         inrc = jstp - nit000 + 2 
     570         IF ( sladatqc%nsstpmpp(inrc) > 0 ) THEN 
     571            sladatqc%nrec = sladatqc%nrec + 1 
     572         ENDIF 
     573      END DO 
     574 
     575      ! Allocate record data 
     576 
     577      ALLOCATE( & 
     578         & sladatqc%mrecstp(sladatqc%nrec) & 
     579         & ) 
     580 
     581      ! Finally save the time step corresponding to record rank 
     582 
     583      irec = 0 
     584      DO jstp = nit000 - 1, nitend 
     585         inrc = jstp - nit000 + 2 
     586         IF ( sladatqc%nsstpmpp(inrc) > 0 ) THEN 
     587            irec = irec + 1 
     588            sladatqc%mrecstp(irec) = inrc 
     589         ENDIF 
     590         IF ( lwp ) THEN 
     591            WRITE(numout,1999) inrc, sladatqc%nsstpmpp(inrc) 
     592         ENDIF 
     593 
     594      END DO 
     595       
     596      ! Print record information 
     597 
     598      IF( lwp ) THEN 
     599         WRITE(numout,*) 
     600         WRITE(numout,2000) 
     601         WRITE(numout,2001) 
     602         DO irec = 1, sladatqc%nrec 
     603            WRITE(numout,1999) irec, sladatqc%mrecstp(irec) 
     604         END DO 
     605      ENDIF 
     606 
    5226071997  FORMAT(10X,'Time step',5X,'Sea level anomaly') 
    5236081998  FORMAT(10X,'---------',5X,'-----------------') 
    5246091999  FORMAT(10X,I9,5X,I17) 
     6102000  FORMAT(15X,'Record',10X,'Time step') 
     6112001  FORMAT(15X,'------',10X,'---------') 
    525612 
    526613   END SUBROUTINE obs_pre_sla 
    … …  
    540627      !! History : 
    541628      !!        !  2007-03  (S. Ricci) SST data preparation  
     629      !!        !  2011-10  (O. Titaud) Adding record information 
    542630      !!---------------------------------------------------------------------- 
    543631      !! * Modules used 
    … …  
    567655      INTEGER :: inlasobs     !  - close to land 
    568656      INTEGER :: igrdobs      !  - fail the grid search 
     657      INTEGER :: ibdysobs     !  - close to open boundary  
    569658                              ! Global counters for observations that 
    570659      INTEGER :: iotdobsmpp   !  - outside time domain 
    … …  
    573662      INTEGER :: inlasobsmpp  !  - close to land 
    574663      INTEGER :: igrdobsmpp   !  - fail the grid search 
     664      INTEGER :: ibdysobsmpp  !  - close to open boundary  
    575665      LOGICAL, DIMENSION(:), ALLOCATABLE :: &  
    576666         & llvalid            ! SST data selection 
    … …  
    578668      INTEGER :: jstp         ! Time loop variable 
    579669      INTEGER :: inrc         ! Time index variable 
     670      INTEGER :: irec         ! Record index 
    580671 
    581672      IF(lwp) WRITE(numout,*)'obs_pre_sst : Preparing the SST observations...' 
    … …  
    597688      ilansobs = 0 
    598689      inlasobs = 0 
     690      ibdysobs = 0  
    599691 
    600692      ! ----------------------------------------------------------------------- 
    … …  
    620712      ! ----------------------------------------------------------------------- 
    621713 
    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        ) 
     714      IF (sstdata%lgrid) THEN 
     715         IF(lwp)WRITE(numout,*)'Gridded product, so no land points search.' 
     716         iosdsobs = 0 
     717         ilansobs = 0 
     718         inlasobs = 0 
     719      ELSE 
     720         CALL obs_coo_spc_2d( sstdata%nsurf,              & 
     721            &                 jpi,          jpj,          & 
     722            &                 sstdata%mi,   sstdata%mj,   &  
     723            &                 sstdata%rlam, sstdata%rphi, & 
     724            &                 glamt,        gphit,        & 
     725            &                 tmask(:,:,1), sstdata%nqc,  & 
     726            &                 iosdsobs,     ilansobs,     & 
     727            &                 inlasobs,     ld_nea,       &  
     728            &                 ibdysobs,     ln_bound_reject       )  
     729      ENDIF 
    630730 
    631731      CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    632732      CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    633733      CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
     734      CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp )  
    634735 
    635736      ! ----------------------------------------------------------------------- 
    … …  
    680781               &            inlasobsmpp 
    681782         ENDIF 
     783         WRITE(numout,*) ' Remaining SST data near open boundary (removed) = ', & 
     784            &               ibdysobsmpp  
    682785         WRITE(numout,*) ' SST data accepted                             = ', & 
    683786            &            sstdatqc%nsurfmpp 
    … …  
    705808      ENDIF 
    706809 
     810      !--------------------------------------------------------- 
     811      ! Record handling 
     812      !--------------------------------------------------------- 
     813 
     814      ! First count the number of records 
     815 
     816      sstdatqc%nrec = 0 
     817      DO jstp = nit000 - 1, nitend 
     818         inrc = jstp - nit000 + 2 
     819         IF ( sstdatqc%nsstpmpp(inrc) > 0 ) THEN 
     820            sstdatqc%nrec = sstdatqc%nrec + 1 
     821         ENDIF 
     822      END DO 
     823 
     824      ! Allocate record data 
     825 
     826      ALLOCATE( & 
     827         & sstdatqc%mrecstp(sstdatqc%nrec) & 
     828         & ) 
     829 
     830      ! Finally save the time step corresponding to record rank 
     831 
     832      irec = 0 
     833      DO jstp = nit000 - 1, nitend 
     834         inrc = jstp - nit000 + 2 
     835         IF ( sstdatqc%nsstpmpp(inrc) > 0 ) THEN 
     836            irec = irec + 1 
     837            sstdatqc%mrecstp(irec) = inrc 
     838         ENDIF 
     839         IF ( lwp ) THEN 
     840            WRITE(numout,1999) jstp, sstdatqc%nsstpmpp(inrc) 
     841         ENDIF 
     842 
     843      END DO 
     844       
     845      ! Print record information 
     846 
     847      IF( lwp ) THEN 
     848         WRITE(numout,*) 
     849         WRITE(numout,2000) 
     850         WRITE(numout,2001) 
     851         DO irec = 1, sstdatqc%nrec 
     852            WRITE(numout,1999) irec, sstdatqc%mrecstp(irec) - 1 
     853         END DO 
     854      ENDIF 
     855 
    7078561997  FORMAT(10X,'Time step',5X,'Sea surface temperature') 
    708 1998  FORMAT(10X,'---------',5X,'-----------------') 
     8571998  FORMAT(10X,'---------',5X,'-----------------------') 
    7098581999  FORMAT(10X,I9,5X,I17) 
     8592000  FORMAT(15X,'Record',10X,'Time step') 
     8602001  FORMAT(15X,'------',10X,'---------') 
    710861       
    711862   END SUBROUTINE obs_pre_sst 
    … …  
    752903      INTEGER :: inlasobs     !  - close to land 
    753904      INTEGER :: igrdobs      !  - fail the grid search 
     905      INTEGER :: ibdysobs     !  - close to open boundary  
    754906                              ! Global counters for observations that 
    755907      INTEGER :: iotdobsmpp   !  - outside time domain 
    … …  
    758910      INTEGER :: inlasobsmpp  !  - close to land 
    759911      INTEGER :: igrdobsmpp   !  - fail the grid search 
     912      INTEGER :: ibdysobsmpp  !  - close to open boundary  
    760913      LOGICAL, DIMENSION(:), ALLOCATABLE :: &  
    761914         & llvalid            ! data selection 
    … …  
    763916      INTEGER :: jstp         ! Time loop variable 
    764917      INTEGER :: inrc         ! Time index variable 
     918      INTEGER :: irec         ! Record index 
    765919 
    766920      IF (lwp) WRITE(numout,*)'obs_pre_seaice : Preparing the sea ice observations...' 
    … …  
    782936      ilansobs = 0 
    783937      inlasobs = 0 
     938      ibdysobs = 0  
    784939 
    785940      ! ----------------------------------------------------------------------- 
    … …  
    812967         &                 tmask(:,:,1),    seaicedata%nqc,  & 
    813968         &                 iosdsobs,        ilansobs,        & 
    814          &                 inlasobs,        ld_nea           ) 
    815  
     969         &                 inlasobs,        ld_nea,          &  
     970         &                 ibdysobs,      ln_bound_reject     )  
     971          
    816972      CALL obs_mpp_sum_integer( iosdsobs, iosdsobsmpp ) 
    817973      CALL obs_mpp_sum_integer( ilansobs, ilansobsmpp ) 
    818974      CALL obs_mpp_sum_integer( inlasobs, inlasobsmpp ) 
     975      CALL obs_mpp_sum_integer( ibdysobs, ibdysobsmpp )  
    819976 
    820977      ! ----------------------------------------------------------------------- 
    … …  
    8651022               &            inlasobsmpp 
    8661023         ENDIF 
     1024         WRITE(numout,*) ' Remaining sea ice data near open boundary (removed) = ', &  
     1025            &            ibdysobsmpp  
    8671026         WRITE(numout,*) ' Sea ice data accepted                             = ', & 
    8681027            &            seaicedatqc%nsurfmpp 
    … …  
    8901049      ENDIF 
    8911050 
    892 1997  FORMAT(10X,'Time step',5X,'Sea ice data           ') 
    893 1998  FORMAT(10X,'---------',5X,'-----------------') 
     1051      !--------------------------------------------------------- 
     1052      ! Record handling 
     1053      !--------------------------------------------------------- 
     1054 
     1055      ! First count the number of records 
     1056 
     1057      seaicedatqc%nrec = 0 
     1058      DO jstp = nit000 - 1, nitend 
     1059         inrc = jstp - nit000 + 2 
     1060         IF ( seaicedatqc%nsstpmpp(inrc) > 0 ) THEN 
     1061            seaicedatqc%nrec = seaicedatqc%nrec + 1 
     1062         ENDIF 
     1063      END DO 
     1064 
     1065      ! Allocate record data 
     1066 
     1067      ALLOCATE( & 
     1068         & seaicedatqc%mrecstp(seaicedatqc%nrec) & 
     1069         & ) 
     1070 
     1071      ! Finally save the time step corresponding to record rank 
     1072 
     1073      irec = 0 
     1074      DO jstp = nit000 - 1, nitend 
     1075         inrc = jstp - nit000 + 2 
     1076         IF ( seaicedatqc%nsstpmpp(inrc) > 0 ) THEN 
     1077            irec = irec + 1 
     1078            seaicedatqc%mrecstp(irec) = inrc 
     1079         ENDIF 
     1080         IF ( lwp ) THEN 
     1081            WRITE(numout,1999) inrc, seaicedatqc%nsstpmpp(inrc) 
     1082         ENDIF 
     1083 
     1084      END DO 
     1085       
     1086      ! Print record information 
     1087 
     1088      IF( lwp ) THEN 
     1089         WRITE(numout,*) 
     1090         WRITE(numout,2000) 
     1091         WRITE(numout,2001) 
     1092         DO irec = 1, seaicedatqc%nrec 
     1093            WRITE(numout,1999) irec, seaicedatqc%mrecstp(irec) 
     1094         END DO 
     1095      ENDIF 
     1096 
     10971997  FORMAT(10X,'Time step',5X,'Sea ice data') 
     10981998  FORMAT(10X,'---------',5X,'------------') 
    89410991999  FORMAT(10X,I9,5X,I17) 
     11002000  FORMAT(15X,'Record',10X,'Time step') 
     11012001  FORMAT(15X,'------',10X,'---------') 
    8951102       
    8961103   END SUBROUTINE obs_pre_seaice 
    … …  
    9411148      INTEGER :: inlavobs     !  - close to land (meridional velocity component) 
    9421149      INTEGER :: igrdobs      !  - fail the grid search 
     1150      INTEGER :: ibdyuobs     !  - close to open boundary  
     1151      INTEGER :: ibdyvobs     !  - close to open boundary        
    9431152      INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    9441153      INTEGER :: iuvchkv      ! 
    … …  
    9521161      INTEGER :: inlavobsmpp  !  - close to land (meridional velocity component) 
    9531162      INTEGER :: igrdobsmpp   !  - fail the grid search 
     1163      INTEGER :: ibdyuobsmpp  !  - close to open boundary  
     1164      INTEGER :: ibdyvobsmpp  !  - close to open boundary  
    9541165      INTEGER :: iuvchkumpp   !  - reject u if v rejected and vice versa 
    9551166      INTEGER :: iuvchkvmpp   ! 
    … …  
    9831194      inlauobs = 0 
    9841195      inlavobs = 0 
     1196      ibdyuobs = 0  
     1197      ibdyvobs = 0  
    9851198      iuvchku  = 0 
    9861199      iuvchkv = 0 
    … …  
    10351248         &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    10361249         &                 iosduobs,              ilanuobs,             & 
    1037          &                 inlauobs,              ld_nea                ) 
     1250         &                 inlauobs,              ld_nea,               &  
     1251         &                 ibdyuobs,              ln_bound_reject       )  
    10381252 
    10391253      CALL obs_mpp_sum_integer( iosduobs, iosduobsmpp ) 
    10401254      CALL obs_mpp_sum_integer( ilanuobs, ilanuobsmpp ) 
    10411255      CALL obs_mpp_sum_integer( inlauobs, inlauobsmpp ) 
     1256      CALL obs_mpp_sum_integer( ibdyuobs, ibdyuobsmpp )  
    10421257 
    10431258      ! Meridional Velocity Component 
    … …  
    10551270         &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    10561271         &                 iosdvobs,              ilanvobs,             & 
    1057          &                 inlavobs,              ld_nea                ) 
     1272         &                 inlavobs,              ld_nea,               &  
     1273         &                 ibdyvobs,              ln_bound_reject       )  
    10581274 
    10591275      CALL obs_mpp_sum_integer( iosdvobs, iosdvobsmpp ) 
    10601276      CALL obs_mpp_sum_integer( ilanvobs, ilanvobsmpp ) 
    10611277      CALL obs_mpp_sum_integer( inlavobs, inlavobsmpp ) 
     1278      CALL obs_mpp_sum_integer( ibdyvobs, ibdyvobsmpp )  
    10621279 
    10631280      ! ----------------------------------------------------------------------- 
    … …  
    11251342               &            inlauobsmpp 
    11261343         ENDIF 
     1344         WRITE(numout,*) ' Remaining U data near open boundary (removed) = ', &  
     1345            &            ibdyuobsmpp  
    11271346         WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
    11281347            &            iuvchku      
    … …  
    11401359               &            inlavobsmpp 
    11411360         ENDIF 
     1361         WRITE(numout,*) ' Remaining V data near open boundary (removed) = ', &  
     1362            &            ibdyvobsmpp  
    11421363         WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
    11431364            &            iuvchkv      
    … …  
    15321753      &                       plam,   pphi,    pmask,            & 
    15331754      &                       kobsqc, kosdobs, klanobs,          & 
    1534       &                       knlaobs,ld_nea                     ) 
     1755      &                       knlaobs,ld_nea,                    &  
     1756      &                       kbdyobs, ld_bound_reject           )  
    15351757      !!---------------------------------------------------------------------- 
    15361758      !!                    ***  ROUTINE obs_coo_spc_2d  *** 
    … …  
    15681790      INTEGER, INTENT(INOUT) :: klanobs   ! Observations within a model land cell 
    15691791      INTEGER, INTENT(INOUT) :: knlaobs   ! Observations near land 
     1792      INTEGER, INTENT(INOUT) :: kbdyobs     ! Observations near boundary  
    15701793      LOGICAL, INTENT(IN) :: ld_nea       ! Flag observations near land 
     1794      LOGICAL, INTENT(IN) :: ld_bound_reject  ! Flag observations near open boundary  
    15711795      !! * Local declarations 
    15721796      REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 
    15731797         & zgmsk              ! Grid mask 
     1798#if defined key_bdy   
     1799      REAL(KIND=wp), DIMENSION(2,2,kobsno) :: &  
     1800         & zbmsk              ! Boundary mask  
     1801      REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask  
     1802#endif  
    15741803      REAL(KIND=wp), DIMENSION(2,2,kobsno) :: & 
    15751804         & zglam, &           ! Model longitude at grid points 
    … …  
    16131842 
    16141843      END DO 
     1844 
     1845#if defined key_bdy              
     1846      ! Create a mask grid points in boundary rim  
     1847      IF (ld_bound_reject) THEN  
     1848         zbdymask(:,:) = 1.0_wp  
     1849         DO ji = 1, nb_bdy  
     1850            DO jj = 1, idx_bdy(ji)%nblen(1)  
     1851               zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp  
     1852            ENDDO  
     1853         ENDDO  
     1854  
     1855         CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, zbdymask, zbmsk )        
     1856      ENDIF  
     1857#endif  
     1858 
    16151859       
    16161860      CALL obs_int_comm_2d( 2, 2, kobsno, igrdi, igrdj, pmask, zgmsk ) 
    … …  
    16711915         ! Flag if the observation falls is close to land 
    16721916         IF ( MINVAL( zgmsk(1:2,1:2,jobs) ) == 0.0_wp) THEN 
    1673             IF (ld_nea) kobsqc(jobs) = kobsqc(jobs) + 14 
    16741917            knlaobs = knlaobs + 1 
    1675             CYCLE 
    1676          ENDIF 
     1918            IF (ld_nea) THEN  
     1919               kobsqc(jobs) = kobsqc(jobs) + 14  
     1920               CYCLE  
     1921            ENDIF  
     1922         ENDIF 
     1923 
     1924#if defined key_bdy  
     1925         ! Flag if the observation falls close to the boundary rim  
     1926         IF (ld_bound_reject) THEN  
     1927            IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN  
     1928               kobsqc(jobs) = kobsqc(jobs) + 15  
     1929               kbdyobs = kbdyobs + 1  
     1930               CYCLE  
     1931            ENDIF  
     1932            ! for observations on the grid...  
     1933            IF (lgridobs) THEN  
     1934               IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN  
     1935                  kobsqc(jobs) = kobsqc(jobs) + 15  
     1936                  kbdyobs = kbdyobs + 1  
     1937                  CYCLE  
     1938               ENDIF  
     1939            ENDIF  
     1940         ENDIF  
     1941#endif  
    16771942             
    16781943      END DO 
    … …  
    16861951      &                       plam,    pphi,    pdep,    pmask, & 
    16871952      &                       kpobsqc, kobsqc,  kosdobs,        & 
    1688       &                       klanobs, knlaobs, ld_nea          ) 
     1953      &                       klanobs, knlaobs, ld_nea,         &  
     1954      &                       kbdyobs, ld_bound_reject          )  
    16891955      !!---------------------------------------------------------------------- 
    16901956      !!                    ***  ROUTINE obs_coo_spc_3d  *** 
    … …  
    17091975      !! * Modules used 
    17101976      USE dom_oce, ONLY : &       ! Geographical information 
    1711          & gdepw_0                         
     1977         & ln_zco,        & 
     1978         & ln_zps,        & 
     1979         & gdepw_0,       &                         
     1980#if defined key_vvl 
     1981         & gdepw_1,       & 
     1982    & gdept_1 
     1983#else 
     1984         & gdepw,         & 
     1985    & gdept 
     1986#endif  
    17121987 
    17131988      !! * Arguments 
    … …  
    17432018      INTEGER, INTENT(INOUT) :: klanobs     ! Observations within a model land cell 
    17442019      INTEGER, INTENT(INOUT) :: knlaobs     ! Observations near land 
     2020      INTEGER, INTENT(INOUT) :: kbdyobs     ! Observations near boundary 
    17452021      LOGICAL, INTENT(IN) :: ld_nea         ! Flag observations near land 
     2022      LOGICAL, INTENT(IN) :: ld_bound_reject  ! Flag observations near open boundary   
    17462023      !! * Local declarations 
    17472024      REAL(KIND=wp), DIMENSION(2,2,kpk,kprofno) :: & 
    17482025         & zgmsk              ! Grid mask 
     2026#if defined key_bdy   
     2027      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: &  
     2028         & zbmsk              ! Boundary mask  
     2029      REAL(KIND=wp), DIMENSION(jpi,jpj) :: zbdymask  
     2030#endif  
    17492031      REAL(KIND=wp), DIMENSION(2,2,kprofno) :: & 
    17502032         & zglam, &           ! Model longitude at grid points 
    … …  
    17542036         & igrdj 
    17552037      LOGICAL :: lgridobs           ! Is observation on a model grid point. 
     2038      LOGICAL :: ll_next_to_land    ! Is a profile next to land 
    17562039      INTEGER :: iig, ijg           ! i,j of observation on model grid point. 
    17572040      INTEGER :: jobs, jobsp, jk, ji, jj 
    … …  
    17882071          
    17892072      END DO 
     2073 
     2074#if defined key_bdy   
     2075      ! Create a mask grid points in boundary rim  
     2076      IF (ld_bound_reject) THEN             
     2077         zbdymask(:,:) = 1.0_wp  
     2078         DO ji = 1, nb_bdy  
     2079            DO jj = 1, idx_bdy(ji)%nblen(1)  
     2080               zbdymask(idx_bdy(ji)%nbi(jj,1),idx_bdy(ji)%nbj(jj,1)) = 0.0_wp  
     2081            ENDDO  
     2082         ENDDO  
     2083      ENDIF  
     2084  
     2085      CALL obs_int_comm_2d( 2, 2, kprofno, igrdi, igrdj, zbdymask, zbmsk )  
     2086#endif  
    17902087       
    17912088      CALL obs_int_comm_3d( 2, 2, kprofno, kpk, igrdi, igrdj, pmask, zgmsk ) 
    … …  
    18162113         END DO 
    18172114 
     2115         ! Check if next to land 
     2116         IF (  ANY( zgmsk(1:2,1:2,1,jobs) == 0.0_wp ) ) THEN 
     2117           ll_next_to_land=.TRUE. 
     2118         ELSE 
     2119           ll_next_to_land=.FALSE. 
     2120         ENDIF 
     2121          
    18182122         ! Reject observations 
    18192123 
    … …  
    18322136            ENDIF 
    18332137 
    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 
     2138            ! To check if an observations falls within land there are two cases: 
     2139       ! 1: z-coordibnates, where the check uses the mask 
     2140       ! 2: terrain following (eg s-coordinates),  
     2141            !    where we use the depth of the bottom cell to mask observations 
     2142             
     2143            IF( ln_zps .OR. ln_zco ) THEN !(CASE 1) 
     2144                
     2145               ! Flag if the observation falls with a model land cell 
     2146               IF ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 
     2147                  &  == 0.0_wp ) THEN 
     2148                  kobsqc(jobsp) = kobsqc(jobsp) + 12 
     2149                  klanobs = klanobs + 1 
     2150                  CYCLE 
     2151               ENDIF 
     2152             
     2153               ! Flag if the observation is close to land 
     2154               IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 
     2155                  &  0.0_wp) THEN 
     2156                  knlaobs = knlaobs + 1 
     2157                  IF (ld_nea) THEN   
     2158                     kobsqc(jobsp) = kobsqc(jobsp) + 14  
     2159                  ENDIF  
     2160               ENDIF 
     2161             
     2162            ELSE ! Case 2 
     2163 
     2164               ! Flag if the observation is deeper than the bathymetry 
     2165               ! Or if it is within the mask 
     2166               IF ( ALL( & 
     2167               &  fsdepw(kobsi(jobs)-1:kobsi(jobs)+1,kobsj(jobs)-1:kobsj(jobs)+1,kpk) & 
     2168               & < pobsdep(jobsp) ) & 
     2169               &     .OR. & 
     2170               &  ( SUM( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) & 
     2171               &  == 0.0_wp) ) THEN 
     2172                  kobsqc(jobsp) = kobsqc(jobsp) + 12 
     2173                  klanobs = klanobs + 1 
     2174                  CYCLE 
     2175               ENDIF 
     2176                
     2177               ! Flag if the observation is close to land 
     2178               IF ( ll_next_to_land ) THEN 
     2179                  knlaobs = knlaobs + 1 
     2180                  IF (ld_nea) THEN   
     2181                     kobsqc(jobsp) = kobsqc(jobsp) + 14  
     2182                  ENDIF  
     2183               ENDIF 
     2184             
    18402185            ENDIF 
    1841  
     2186             
    18422187            ! For observations on the grid reject them if their are at 
    18432188            ! a masked point 
    … …  
    18512196            ENDIF 
    18522197             
    1853             ! Flag if the observation falls is close to land 
    1854             IF ( MINVAL( zgmsk(1:2,1:2,kobsk(jobsp)-1:kobsk(jobsp),jobs) ) == & 
    1855                &  0.0_wp) THEN 
    1856                IF (ld_nea) kobsqc(jobsp) = kobsqc(jobsp) + 14 
    1857                knlaobs = knlaobs + 1 
    1858             ENDIF 
    1859  
    18602198            ! Set observation depth equal to that of the first model depth 
    18612199            IF ( pobsdep(jobsp) <= pdep(1) ) THEN 
    18622200               pobsdep(jobsp) = pdep(1)   
    18632201            ENDIF 
     2202 
     2203#if defined key_bdy  
     2204            ! Flag if the observation falls close to the boundary rim  
     2205            IF (ld_bound_reject) THEN  
     2206               IF ( MINVAL( zbmsk(1:2,1:2,jobs) ) == 0.0_wp ) THEN  
     2207                  kobsqc(jobsp) = kobsqc(jobsp) + 15  
     2208                  kbdyobs = kbdyobs + 1  
     2209                  CYCLE  
     2210               ENDIF  
     2211               ! for observations on the grid...  
     2212               IF (lgridobs) THEN  
     2213                  IF (zbmsk(iig,ijg,jobs) == 0.0_wp ) THEN  
     2214                     kobsqc(jobsp) = kobsqc(jobsp) + 15  
     2215                     kbdyobs = kbdyobs + 1  
     2216                     CYCLE  
     2217                  ENDIF  
     2218               ENDIF  
     2219            ENDIF  
     2220#endif  
    18642221             
    18652222         END DO 

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

    r7363 r7367  
    496496            & prof%var(kvar)%vext(kobs,kext) & 
    497497            & ) 
     498         prof%var(kvar)%vext(:,:) = 0.0_wp 
    498499      ENDIF 
    499500 

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

    r7363 r7367  
    791791      !----------------------------------------------------------------------- 
    792792      ! Model level search 
    793       !----------------------------------------------------------------------- 
    794       IF ( ldt3d ) THEN 
    795          CALL obs_level_search( jpk, gdept_0, & 
    796             & profdata%nvprot(1), profdata%var(1)%vdep, & 
    797             & profdata%var(1)%mvk ) 
    798       ENDIF 
    799       IF ( lds3d ) THEN 
    800          CALL obs_level_search( jpk, gdept_0, & 
    801             & profdata%nvprot(2), profdata%var(2)%vdep, & 
    802             & profdata%var(2)%mvk ) 
     793      ! Only calculated here for z-levels and partial steps.  
     794      ! Otherwise calculated in obs_oper 
     795      !----------------------------------------------------------------------- 
     796      IF ( ln_zco .OR. ln_zps ) THEN 
     797         IF ( ldt3d ) THEN 
     798            CALL obs_level_search( jpk, gdept_0, & 
     799               & profdata%nvprot(1), profdata%var(1)%vdep, & 
     800               & profdata%var(1)%mvk ) 
     801         ENDIF 
     802         IF ( lds3d ) THEN 
     803            CALL obs_level_search( jpk, gdept_0, & 
     804               & profdata%nvprot(2), profdata%var(2)%vdep, & 
     805               & profdata%var(2)%mvk ) 
     806         ENDIF 
     807      ELSE 
     808         profdata%var(1)%mvk = 0 
     809         profdata%var(2)%mvk = 0   
    803810      ENDIF 
    804811       

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_seaice.F90

    r7363 r7367  
    3131 
    3232   PUBLIC obs_rea_seaice      ! Read the seaice observations from the point data 
     33   PUBLIC obs_rea_seaice_grd  ! Read the seaice observations from gridded data 
    3334    
    3435   !!---------------------------------------------------------------------- 
    … …  
    5859      !! History :   
    5960      !!      ! :  2009-01 (K. Mogensen) Initial version based on old versions 
     61      !!      ! :  2011-07 (D. Lea) Minor fixes for reading sea ice feedback files 
    6062      !!---------------------------------------------------------------------- 
    6163      !! * Modules used 
    … …  
    175177             
    176178            !------------------------------------------------------------------ 
    177             !  Close the file since it is opened in read_proffile 
     179            !  Close the file since it is opened above 
    178180            !------------------------------------------------------------------ 
    179181             
    … …  
    181183 
    182184            !------------------------------------------------------------------ 
    183             !  Read the profile file into inpfiles 
     185            !  Read the data file into inpfiles structure 
    184186            !------------------------------------------------------------------ 
    185187            IF ( kformat == 0 ) THEN 
    … …  
    192194               CALL read_obfbdata( TRIM( cfilenames(jj) ), inpfiles(jj), & 
    193195                  &                ldgrid = .TRUE. ) 
    194                IF ( ldmod .AND. ( ( inpfiles(jj)%nadd == 0 ) .OR.& 
    195                   &               ( inpfiles(jj)%next < 2 ) ) ) THEN 
     196               IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 
    196197                  CALL ctl_stop( 'Model not in input data' ) 
    197198                  RETURN 
    … …  
    237238            inowin = 0 
    238239            DO ji = 1, inpfiles(jj)%nobs 
     240               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     241               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    239242               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    240243                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    249252            inowin = 0 
    250253            DO ji = 1, inpfiles(jj)%nobs 
     254               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     255               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    251256               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    252257                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    261266            inowin = 0 
    262267            DO ji = 1, inpfiles(jj)%nobs 
     268               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     269               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    263270               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    264271                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    272279 
    273280            DO ji = 1, inpfiles(jj)%nobs 
     281               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     282               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    274283               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    275284                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    296305 
    297306      !--------------------------------------------------------------------- 
    298       !  Loop over input data files to count total number of profiles 
     307      !  Loop over input data files to count total number of obs 
    299308      !--------------------------------------------------------------------- 
    300309      iobstot = 0 
    301310      DO jj = 1, inobf 
    302311         DO ji = 1, inpfiles(jj)%nobs 
     312            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     313            IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    303314            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    304315               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    313324      DO jj = 1, inobf 
    314325         DO ji = 1, inpfiles(jj)%nobs 
     326            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     327            IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    315328            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    316329               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    339352         jj = ifileidx(iindx(jk)) 
    340353         ji = iseaiceidx(iindx(jk)) 
     354 
     355         IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     356         IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
     357 
    341358         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  & 
    342359            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    … …  
    452469   END SUBROUTINE obs_rea_seaice 
    453470 
     471   SUBROUTINE obs_rea_seaice_grd( icename, cdicefmt, icedata, kvars, kextra, & 
     472      &                           kstp, ddobsini, ddobsend ) 
     473      !!--------------------------------------------------------------------- 
     474      !! 
     475      !!                   *** ROUTINE obs_rea_ice *** 
     476      !! 
     477      !! ** Purpose : Read from file the pseudo ICE data from gridded data 
     478      !! 
     479      !! ** Method  :  
     480      !! 
     481      !! ** Action  :  
     482      !! 
     483      !! References :  
     484      !! 
     485      !! History :   
     486      !!      ! :   
     487      !!---------------------------------------------------------------------- 
     488      !! * Modules used 
     489      USE par_oce          ! Ocean parameters 
     490    
     491      !! * Arguments 
     492      CHARACTER(len=128), INTENT(IN) :: icename   ! Generic file name 
     493      CHARACTER(len=12), INTENT(IN) :: cdicefmt   ! Format of ICE files (yearly/monthly) 
     494      TYPE(obs_surf), INTENT(INOUT) :: icedata    ! ICE data 
     495      REAL(KIND=dp), INTENT(IN) :: ddobsini    ! Obs. ini time in YYYYMMDD.HHMMSS 
     496      REAL(KIND=dp), INTENT(IN) :: ddobsend    ! Obs. end time in YYYYMMDD.HHMMSS 
     497      INTEGER, INTENT(IN) :: kvars      ! Number of variables in icedata structures 
     498      INTEGER, INTENT(IN) :: kextra     ! Number of extra variables in icedata structures 
     499      INTEGER, INTENT(IN) :: kstp       ! Ocean time-step index 
     500       
     501      INTEGER :: iyear 
     502      INTEGER :: imon 
     503      INTEGER :: iday 
     504      INTEGER :: ihour 
     505      INTEGER :: imin 
     506      INTEGER :: isec 
     507      INTEGER :: ihhmmss 
     508      INTEGER :: iyear1 
     509      INTEGER :: iyear2 
     510      INTEGER :: imon1 
     511      INTEGER :: imon2 
     512      INTEGER :: iyearf 
     513      INTEGER :: imonf 
     514      REAL(KIND=wp) :: pjulini 
     515      REAL(KIND=wp) :: pjulend 
     516      REAL(KIND=wp) :: pjulb 
     517      REAL(KIND=wp) :: pjule 
     518      REAL(KIND=wp) :: pjul 
     519      INTEGER :: inumice 
     520      INTEGER :: itotrec 
     521      INTEGER :: inumobs 
     522      INTEGER :: irec 
     523      INTEGER :: ifld 
     524      INTEGER :: inum 
     525      INTEGER :: ji, jj 
     526      CHARACTER(len=128) :: clname 
     527      CHARACTER(len=4) :: cdyear 
     528      CHARACTER(len=2) :: cdmon 
     529      REAL(kind=wp), ALLOCATABLE, DIMENSION(:,:,:) :: zicein 
     530 
     531      IF (lwp) WRITE(numout,*)'In obs_rea_ice_grd',icename 
     532 
     533      !----------------------------------------------------------------------- 
     534      ! Convert observation window to julian dates. 
     535      !----------------------------------------------------------------------- 
     536      iyear1 = NINT( ddobsini / 10000 ) 
     537      imon1 = NINT( ( ddobsini - iyear1 * 10000 ) / 100 ) 
     538      iday = MOD( NINT( ddobsini ), 100 ) 
     539      ihhmmss = ( ddobsini - NINT( ddobsini ) ) * 1000000 
     540      ihour = ihhmmss / 10000 
     541      imin = ( ihhmmss - ihour * 100 ) / 100 
     542      isec = MOD( ihhmmss, 100 ) 
     543      CALL greg2jul ( isec, imin, ihour, iday, imon1, iyear1, pjulini ) 
     544      IF (lwp) WRITE(numout,*)'dateini',ddobsini,iyear1,imon1,iday,ihour, & 
     545         & imin,isec,pjulini 
     546 
     547      iyear2 = NINT( ddobsini / 10000 ) 
     548      imon2 = NINT( ( ddobsend - iyear2 * 10000 ) / 100 ) 
     549      iday = MOD( NINT( ddobsend ), 100 ) 
     550      ihhmmss = ( ddobsend - NINT( ddobsend ) ) * 1000000 
     551      ihour = ihhmmss / 10000 
     552      imin = ( ihhmmss - ihour * 100 ) / 100 
     553      isec = MOD( ihhmmss, 100 ) 
     554      CALL greg2jul ( isec, imin, ihour, iday, imon2, iyear2, pjulend ) 
     555      IF (lwp) WRITE(numout,*)'dateend',ddobsend,iyear2,imon2,iday,ihour, & 
     556         & imin,isec,pjulend 
     557 
     558      itotrec = NINT( pjulend - pjulini )  
     559      ALLOCATE( & 
     560         & zicein( jpi, jpj, itotrec) & 
     561         & ) 
     562       
     563      pjul = pjulini + 1 
     564       
     565      iyearf = -1  
     566      imonf = -1 
     567 
     568      IF ( TRIM(cdicefmt) == 'yearly' ) THEN 
     569 
     570         DO 
     571          
     572            CALL jul2greg( isec, imin, ihour, iday, imon, iyear, & 
     573               &           pjul, 19500101 ) 
     574            ! 
     575            IF ( iyear /= iyearf ) THEN 
     576                
     577               CALL greg2jul ( 0, 0, 0, 1, 1, iyear, pjulb ) 
     578                
     579               IF ( iyearf /= -1 ) THEN 
     580                   
     581                  CALL iom_close ( inumice )       
     582                   
     583               ENDIF 
     584                
     585               clname = icename 
     586               jj = INDEX( clname, 'YYYY' ) 
     587                
     588               IF ( jj == 0 ) THEN 
     589                   
     590                  CALL ctl_stop( 'obs_rea_ice_grd : ', & 
     591                  &           'Error processing filename ' // TRIM(icename) ) 
     592                   
     593               ENDIF 
     594                
     595               WRITE(cdyear,'(I4.4)') iyear 
     596               clname(jj:jj+3) = cdyear 
     597               IF(lwp) WRITE(numout,*)'Reading from gridded ICE file : ',& 
     598                  & TRIM(clname) 
     599                
     600               inumice = 0 
     601                
     602               CALL iom_open ( clname, inumice ) 
     603                
     604               IF ( inumice == 0 ) THEN 
     605                   
     606                  CALL ctl_stop( 'obs_rea_ice_grd : ', & 
     607                     &           'Error reading ' // TRIM(clname) ) 
     608                   
     609               ENDIF 
     610                
     611               iyearf = iyear 
     612                
     613            ENDIF 
     614             
     615            irec = pjul - pjulb + 1 
     616            ifld = pjul - pjulini 
     617             
     618            CALL iom_get ( inumice, jpdom_data, 'ice_cov', zicein(:,:,ifld), irec ) 
     619             
     620            pjul = pjul + 1 
     621             
     622            IF ( pjul > pjulend ) EXIT 
     623          
     624         END DO 
     625 
     626      ELSEIF ( TRIM(cdicefmt) == 'monthly' ) THEN 
     627 
     628         DO 
     629          
     630            CALL jul2greg( isec, imin, ihour, iday, imon, iyear, & 
     631               &           pjul, 19500101 ) 
     632            ! 
     633            IF ( iyear /= iyearf .OR. imon /= imonf ) THEN 
     634                
     635               CALL greg2jul ( 0, 0, 0, 1, imon, iyear, pjulb ) 
     636                
     637               IF ( iyearf /= -1 .AND. imonf /= -1 ) THEN 
     638                   
     639                  CALL iom_close ( inumice )       
     640                   
     641               ENDIF 
     642                
     643               clname = icename 
     644 
     645               jj = INDEX( clname, 'YYYY' ) 
     646 
     647               IF ( jj == 0 ) THEN 
     648                   
     649                  CALL ctl_stop( 'obs_rea_ice_grd : ', & 
     650                  &           'Error processing filename ' // TRIM(icename) ) 
     651                   
     652               ENDIF 
     653                
     654               WRITE(cdyear,'(I4.4)') iyear 
     655               clname(jj:jj+3) = cdyear 
     656 
     657               jj = INDEX( clname, 'MM' ) 
     658                
     659               IF ( jj == 0 ) THEN 
     660                   
     661                  CALL ctl_stop( 'obs_rea_ice_grd : ', & 
     662                  &           'Error processing filename ' // TRIM(icename) ) 
     663                   
     664               ENDIF 
     665                
     666               WRITE(cdmon,'(I2.2)') imon 
     667               clname(jj:jj+1) = cdmon 
     668 
     669 
     670               IF(lwp) WRITE(numout,*)'Reading from Grdnolds ICE file : ',& 
     671                  & TRIM(clname) 
     672                
     673               inumice = 0 
     674                
     675               CALL iom_open ( clname, inumice ) 
     676                
     677               IF ( inumice == 0 ) THEN 
     678                   
     679                  CALL ctl_stop( 'obs_rea_ice_grd : ', & 
     680                     &           'Error reading ' // TRIM(clname) ) 
     681                   
     682               ENDIF 
     683                
     684               iyearf = iyear 
     685               imonf = iyear 
     686                
     687            ENDIF 
     688             
     689            irec = pjul - pjulb + 1 
     690            ifld = pjul - pjulini 
     691             
     692            CALL iom_get ( inumice, jpdom_data, 'ice_cov', zicein(:,:,ifld), irec ) 
     693             
     694            pjul = pjul + 1 
     695             
     696            IF ( pjul > pjulend ) EXIT 
     697          
     698         END DO 
     699 
     700      ELSE 
     701          
     702         CALL ctl_stop('Unknown GRDNOLDS ice input data file format') 
     703 
     704      ENDIF 
     705 
     706      CALL iom_close ( inumice )       
     707 
     708      inumobs = 0 
     709      DO jj = nldj, nlej 
     710         DO ji = nldi, nlei 
     711            IF ( tmask_i(ji,jj) == 1.0_wp ) inumobs = inumobs + 1 
     712         END DO 
     713      END DO 
     714      inumobs = inumobs * itotrec 
     715 
     716      ! Allocate obs_surf data structure for time sorted data 
     717          
     718      CALL obs_surf_alloc( icedata, inumobs, kvars, kextra, kstp ) 
     719 
     720      pjul = pjulini + 1 
     721 
     722      inumobs = 0 
     723 
     724      DO 
     725 
     726         CALL jul2greg( isec, imin, ihour, iday, imon, iyear, & 
     727            &           pjul, 19500101 ) 
     728 
     729         ifld = pjul - pjulini 
     730 
     731         DO jj = nldj, nlej 
     732            DO ji = nldi, nlei 
     733 
     734               IF ( tmask_i(ji,jj) == 1.0_wp ) THEN 
     735 
     736                  inumobs = inumobs + 1 
     737                   
     738                  ! Integer values 
     739                  IF (ln_grid_global) THEN 
     740                     icedata%mi(inumobs)     = MAX(mig(ji),2) 
     741                     icedata%mj(inumobs)     = MAX(mjg(jj),2) 
     742                  ELSE 
     743                     icedata%mi(inumobs)     = MAX(ji,2) 
     744                     icedata%mj(inumobs)     = MAX(jj,2) 
     745                  ENDIF 
     746                  icedata%nsidx(inumobs)  = 0 
     747                  icedata%nsfil(inumobs)  = 0 
     748                  icedata%nyea(inumobs)   = iyear 
     749                  icedata%nmon(inumobs)   = imon 
     750                  icedata%nday(inumobs)   = iday 
     751                  icedata%nhou(inumobs)   = ihour 
     752                  icedata%nmin(inumobs)   = imin 
     753                  icedata%mstp(inumobs)   = 0 
     754                  icedata%nqc(inumobs)    = 0 
     755                  icedata%ntyp(inumobs)   = 0 
     756          
     757                  ! Real values 
     758                  icedata%rlam(inumobs)   = glamt(ji,jj) 
     759                  icedata%rphi(inumobs)   = gphit(ji,jj) 
     760                  icedata%robs(inumobs,1) = zicein(ji,jj,ifld) 
     761                  icedata%rmod(inumobs,1) = fbrmdi 
     762                  icedata%rext(inumobs,:) = fbrmdi 
     763 
     764               ENDIF 
     765 
     766            END DO 
     767         END DO 
     768 
     769         pjul = pjul + 1 
     770 
     771         IF ( pjul > pjulend ) EXIT 
     772 
     773      END DO 
     774 
     775   END SUBROUTINE obs_rea_seaice_grd 
     776 
    454777END MODULE obs_read_seaice 
    455778 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_sla.F90

    r7363 r7367  
    504504         WRITE(numout,'(1X,A)')'Altimeter satellites' 
    505505         WRITE(numout,'(1X,A)')'--------------------' 
    506          DO jj = 1,8 
     506         DO jj = 1, ntypalt + 1 
    507507            IF ( itypmpp(jj) > 0 ) THEN 
    508508               WRITE(numout,'(1X,A38,A2,I10)')calttyp(jj-1),'= ',itypmpp(jj) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_sst.F90

    r7363 r7367  
    88   !!---------------------------------------------------------------------- 
    99   !!   obs_rea_sst : Driver for reading SST data from the GHRSST/feedback 
    10    !!   obs_rea_sst_rey : Driver for reading SST data from Reynolds 
     10   !!   obs_rea_sst_grd : Driver for reading gridded SST data 
    1111   !!---------------------------------------------------------------------- 
    1212 
    … …  
    2323   USE obs_types                ! Observation type definitions 
    2424   USE obs_sst_io               ! I/O for sst files 
    25    USE iom                      ! I/O of fields for Reynolds data 
     25   USE iom                      ! I/O of fields for gridded data 
    2626   USE netcdf                   ! NetCDF library 
    2727 
    … …  
    3232 
    3333   PUBLIC obs_rea_sst      ! Read the SST observations from the point data 
    34    PUBLIC obs_rea_sst_rey  ! Read the gridded Reynolds SST  
     34   PUBLIC obs_rea_sst_grd  ! Read the gridded SST product 
    3535    
    3636   !!---------------------------------------------------------------------- 
    … …  
    4545      &                    sstdata, knumfiles, cfilenames, & 
    4646      &                    kvars, kextr, kstp, ddobsini, ddobsend, & 
    47       &                    ldignmis, ldmod ) 
     47      &                    ldignmis, ldmod, ld_grid ) 
    4848      !!--------------------------------------------------------------------- 
    4949      !! 
    … …  
    7575      LOGICAL, INTENT(IN) :: ldignmis   ! Ignore missing files 
    7676      LOGICAL, INTENT(IN) :: ldmod      ! Initialize model from input data 
     77      LOGICAL, INTENT(IN) :: ld_grid    ! Gridded data 
    7778      REAL(KIND=dp), INTENT(IN) :: ddobsini   ! Obs. ini time in YYYYMMDD.HHMMSS 
    7879      REAL(KIND=dp), INTENT(IN) :: ddobsend   ! Obs. end time in YYYYMMDD.HHMMSS 
    … …  
    109110      REAL(wp), DIMENSION(:), ALLOCATABLE :: & 
    110111         & zphi, & 
    111          & zlam 
     112         & zlam, & 
     113         & ztim 
    112114      REAL(dp), DIMENSION(:), ALLOCATABLE :: & 
    113115         & zdat 
    114       LOGICAL :: llvalprof 
    115116      TYPE(obfbdata), POINTER, DIMENSION(:) :: & 
    116117         & inpfiles 
    … …  
    120121      INTEGER :: iobs 
    121122      INTEGER :: iobstot 
     123      INTEGER :: istd_loc, imod_loc 
    122124      CHARACTER(len=8) :: cl_refdate 
    123125    
    124126      ! Local initialization 
    125127      iobs = 0 
     128       
     129      ! James While 
     130      ! imod_loc and istd_loc hardwired for the moment 
     131      ! However, you could be more general and search for them in the file 
     132      imod_loc = 1 
     133      istd_loc = 2 
     134       
    126135  
    127136      !----------------------------------------------------------------------- 
    … …  
    183192 
    184193            !------------------------------------------------------------------ 
    185             !  Read the profile file into inpfiles 
     194            !  Read the SST file into inpfiles 
    186195            !------------------------------------------------------------------ 
    187196            IF ( kformat == 0 ) THEN 
    … …  
    193202               CALL read_obfbdata( TRIM( cfilenames(jj) ), inpfiles(jj), & 
    194203                  &                ldgrid = .TRUE. ) 
     204               IF ( inpfiles(jj)%nvar < 1 ) THEN 
     205                  CALL ctl_stop( 'Feedback format error' ) 
     206                  RETURN 
     207               ENDIF 
     208               IF ( (TRIM(inpfiles(jj)%cname(1)) /= 'SST') .AND. & 
     209                    (TRIM(inpfiles(jj)%cname(1)) /= 'surft') ) THEN 
     210                  CALL ctl_stop( 'Feedback format variable name error' ) 
     211                  RETURN 
     212               ENDIF  
    195213               IF ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN 
    196214                  CALL ctl_stop( 'Model not in input data' ) 
    … …  
    237255            inowin = 0 
    238256            DO ji = 1, inpfiles(jj)%nobs 
     257               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     258               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    239259               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    240260                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    244264            ALLOCATE( zlam(inowin)  ) 
    245265            ALLOCATE( zphi(inowin)  ) 
     266            ALLOCATE( ztim(inowin)  ) 
    246267            ALLOCATE( iobsi(inowin) ) 
    247268            ALLOCATE( iobsj(inowin) ) 
    … …  
    249270            inowin = 0 
    250271            DO ji = 1, inpfiles(jj)%nobs 
     272               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     273               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    251274               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    252275                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    254277                  zlam(inowin) = inpfiles(jj)%plam(ji) 
    255278                  zphi(inowin) = inpfiles(jj)%pphi(ji) 
     279                  ztim(inowin) = inpfiles(jj)%ptim(ji) - djulini(jj) 
    256280               ENDIF 
    257281            END DO 
    258282 
    259             CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 
     283            IF ( ld_grid ) THEN 
     284                
     285               CALL obs_grid_locate( inowin, zlam, zphi, ztim, iobsi, iobsj, iproc, 'T' ) 
     286 
     287            ELSE 
     288 
     289               CALL obs_grid_search( inowin, zlam, zphi, iobsi, iobsj, iproc, 'T' ) 
     290 
     291            ENDIF 
    260292 
    261293            inowin = 0 
    262294            DO ji = 1, inpfiles(jj)%nobs 
     295               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     296               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    263297               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    264298                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    269303               ENDIF 
    270304            END DO 
    271             DEALLOCATE( zlam, zphi, iobsi, iobsj, iproc ) 
     305            DEALLOCATE( zlam, zphi, ztim, iobsi, iobsj, iproc ) 
    272306 
    273307            DO ji = 1, inpfiles(jj)%nobs 
     308               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     309               IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    274310               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    275311                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    279315                     IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
    280316                  ENDIF 
    281                   llvalprof = .FALSE. 
    282317                  IF ( ( inpfiles(jj)%ivlqc(1,ji,1) == 1 ) .OR. & 
    283318                     & ( inpfiles(jj)%ivlqc(1,ji,1) == 2 ) ) THEN 
    … …  
    301336      DO jj = 1, inobf 
    302337         DO ji = 1, inpfiles(jj)%nobs 
     338            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     339            IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    303340            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    304341               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    313350      DO jj = 1, inobf 
    314351         DO ji = 1, inpfiles(jj)%nobs 
     352            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     353            IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
    315354            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    316355               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    339378         jj = ifileidx(iindx(jk)) 
    340379         ji = isstidx(iindx(jk)) 
     380 
     381         IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     382         IF ( inpfiles(jj)%ivqc(ji,1) > 2 ) CYCLE 
     383 
    341384         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  & 
    342385            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    … …  
    403446               ! Model and MDT is set to fbrmdi unless read from file 
    404447               IF ( ldmod ) THEN 
    405                   sstdata%rmod(iobs,1) = inpfiles(jj)%padd(1,ji,1,1) 
     448                  sstdata%rmod(iobs,1) = inpfiles(jj)%padd(1,ji,imod_loc,1) 
    406449               ELSE 
    407450                  sstdata%rmod(iobs,1) = fbrmdi 
    408451               ENDIF 
     452                
     453               ! Copy in STD 
     454               IF ( TRIM(inpfiles(jj) % caddname(istd_loc)) == "STD" ) THEN 
     455                  sstdata%rstd(iobs,1) = inpfiles(jj)%padd(1,ji,istd_loc,1) 
     456               ELSE 
     457                  sstdata%rstd(iobs,1) = fbrmdi 
     458               ENDIF 
     459 
     460               ! Time in days sinces begining of window. 
     461               IF ( ld_grid ) THEN 
     462                  sstdata%mt(iobs) = INT(inpfiles(jj)%ptim(ji) - djulini(jj)) 
     463               ENDIF 
     464 
    409465            ENDIF 
    410466         ENDIF 
    … …  
    452508      DEALLOCATE( inpfiles ) 
    453509 
     510      !----------------------------------------------------------------------- 
     511      ! Set the grid variables in sstdata 
     512      !----------------------------------------------------------------------- 
     513      sstdata%lgrid = ld_grid 
     514 
    454515   END SUBROUTINE obs_rea_sst 
    455516 
    456    SUBROUTINE obs_rea_sst_rey( sstname, cdsstfmt, sstdata, kvars, kextra, & 
     517   SUBROUTINE obs_rea_sst_grd( sstname, cdsstfmt, sstdata, kvars, kextra, & 
    457518      &                        kstp, ddobsini, ddobsend ) 
    458519      !!--------------------------------------------------------------------- 
    … …  
    460521      !!                   *** ROUTINE obs_rea_sst *** 
    461522      !! 
    462       !! ** Purpose : Read from file the pseudo SST data from Reynolds 
     523      !! ** Purpose : Read from file the pseudo SST data from gridded data 
    463524      !! 
    464525      !! ** Method  :  
    … …  
    514575      REAL(kind=wp), ALLOCATABLE, DIMENSION(:,:,:) :: zsstin 
    515576 
    516       IF (lwp) WRITE(numout,*)'In obs_rea_sst_rey',sstname 
     577      IF (lwp) WRITE(numout,*)'In obs_rea_sst_grd',sstname 
    517578 
    518579      !----------------------------------------------------------------------- 
    … …  
    530591         & imin,isec,pjulini 
    531592 
    532       iyear2 = NINT( ddobsini / 10000 ) 
     593      iyear2 = NINT( ddobsend / 10000 ) 
    533594      imon2 = NINT( ( ddobsend - iyear2 * 10000 ) / 100 ) 
    534595      iday = MOD( NINT( ddobsend ), 100 ) 
    … …  
    573634               IF ( jj == 0 ) THEN 
    574635                   
    575                   CALL ctl_stop( 'obs_rea_sst_rey : ', & 
     636                  CALL ctl_stop( 'obs_rea_sst_grd : ', & 
    576637                  &           'Error processing filename ' // TRIM(sstname) ) 
    577638                   
    … …  
    580641               WRITE(cdyear,'(I4.4)') iyear 
    581642               clname(jj:jj+3) = cdyear 
    582                IF(lwp) WRITE(numout,*)'Reading from Reynolds SST file : ',& 
     643               IF(lwp) WRITE(numout,*)'Reading from gridded SST file : ',& 
    583644                  & TRIM(clname) 
    584645                
    … …  
    589650               IF ( inumsst == 0 ) THEN 
    590651                   
    591                   CALL ctl_stop( 'obs_rea_sst_rey : ', & 
     652                  CALL ctl_stop( 'obs_rea_sst_grd : ', & 
    592653                     &           'Error reading ' // TRIM(clname) ) 
    593654                   
    … …  
    632693               IF ( jj == 0 ) THEN 
    633694                   
    634                   CALL ctl_stop( 'obs_rea_sst_rey : ', & 
     695                  CALL ctl_stop( 'obs_rea_sst_grd : ', & 
    635696                  &           'Error processing filename ' // TRIM(sstname) ) 
    636697                   
    … …  
    644705               IF ( jj == 0 ) THEN 
    645706                   
    646                   CALL ctl_stop( 'obs_rea_sst_rey : ', & 
     707                  CALL ctl_stop( 'obs_rea_sst_grd : ', & 
    647708                  &           'Error processing filename ' // TRIM(sstname) ) 
    648709                   
    … …  
    653714 
    654715 
    655                IF(lwp) WRITE(numout,*)'Reading from Reynolds SST file : ',& 
     716               IF(lwp) WRITE(numout,*)'Reading from gridded SST file : ',& 
    656717                  & TRIM(clname) 
    657718                
    … …  
    662723               IF ( inumsst == 0 ) THEN 
    663724                   
    664                   CALL ctl_stop( 'obs_rea_sst_rey : ', & 
     725                  CALL ctl_stop( 'obs_rea_sst_grd : ', & 
    665726                     &           'Error reading ' // TRIM(clname) ) 
    666727                   
    … …  
    685746      ELSE 
    686747          
    687          CALL ctl_stop('Unknown REYNOLDS sst input data file format') 
     748         CALL ctl_stop('Unknown gridded sst input data file format') 
    688749 
    689750      ENDIF 
    … …  
    694755      DO jj = nldj, nlej 
    695756         DO ji = nldi, nlei 
    696             IF ( tmask(ji,jj,1) == 1.0_wp ) inumobs = inumobs + 1 
     757            IF ( tmask_i(ji,jj) == 1.0_wp ) inumobs = inumobs + 1 
    697758         END DO 
    698759      END DO 
    … …  
    717778            DO ji = nldi, nlei 
    718779 
    719                IF ( tmask(ji,jj,1) == 1.0_wp ) THEN 
     780               IF ( tmask_i(ji,jj) == 1.0_wp ) THEN 
    720781 
    721782                  inumobs = inumobs + 1 
    … …  
    758819      END DO 
    759820 
    760    END SUBROUTINE obs_rea_sst_rey 
     821   END SUBROUTINE obs_rea_sst_grd 
    761822 
    762823END MODULE obs_read_sst 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_vel.F90

    r7363 r7367  
    260260            inowin = 0 
    261261            DO ji = 1, inpfiles(jj)%nobs 
     262               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     263               IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     264                  & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
    262265               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    263266                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    275278            inowin = 0 
    276279            DO ji = 1, inpfiles(jj)%nobs 
     280               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     281               IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     282                  & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
    277283               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    278284                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    288294               & 'V' ) 
    289295 
     296            ! Check that grid search has not failed for one component ! 
     297            ! and not the other 
     298 
     299            DO ji = 1, inowin 
     300               IF ( ( iprocu(ji) < 0 ) .AND. ( iprocv(ji) >= 0 ) ) THEN 
     301                  IF (lwp) THEN 
     302                     WRITE(numout,*) 
     303                     WRITE(numout,'(1X,A,2F14.4)') & 
     304                        & 'Grid search for u failed at ', & 
     305                        & zphi(ji),zlam(ji) 
     306                     WRITE(numout,*)'Changing v grid search status to failed.' 
     307                  ENDIF 
     308                  iprocv(ji) = -1 
     309                  iobsiv(ji) = -1 
     310                  iobsjv(ji) = -1 
     311               ENDIF 
     312               IF ( ( iprocv(ji) < 0 ) .AND. ( iprocu(ji) >= 0 ) ) THEN 
     313                  IF (lwp) THEN 
     314                     WRITE(numout,*) 
     315                     WRITE(numout,'(1X,A,2F14.4)') & 
     316                        & 'Grid search for v failed at ', & 
     317                        & zphi(ji),zlam(ji) 
     318                     WRITE(numout,*)'Changing u grid search status to failed.' 
     319                  ENDIF 
     320                  iprocu(ji) = -1 
     321                  iobsiu(ji) = -1 
     322                  iobsju(ji) = -1 
     323               ENDIF 
     324            ENDDO 
     325 
    290326            inowin = 0 
    291327            DO ji = 1, inpfiles(jj)%nobs 
     328               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     329               IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     330                  & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
    292331               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    293332                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    310349 
    311350            DO ji = 1, inpfiles(jj)%nobs 
     351               IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     352               IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     353                  & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
    312354               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    313355                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    350392      DO jj = 1, inobf 
    351393         DO ji = 1, inpfiles(jj)%nobs 
     394            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     395            IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     396               & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
    352397            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    353398               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    362407      DO jj = 1, inobf 
    363408         DO ji = 1, inpfiles(jj)%nobs 
     409            IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     410            IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     411               & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
    364412            IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    365413               & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    … …  
    395443         jj = ifileidx(iindx(jk)) 
    396444         ji = iprofidx(iindx(jk)) 
     445 
     446         IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE 
     447         IF ( ( inpfiles(jj)%ivqc(ji,1) > 2 ) .OR. & 
     448            & ( inpfiles(jj)%ivqc(ji,2) > 2 )) CYCLE 
     449 
    397450         IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND.  & 
    398451            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    … …  
    613666      !----------------------------------------------------------------------- 
    614667      ! Model level search 
    615       !----------------------------------------------------------------------- 
    616       CALL obs_level_search( jpk, gdept_0, & 
    617          & profdata%nvprot(1), profdata%var(1)%vdep, & 
    618          & profdata%var(1)%mvk ) 
    619       CALL obs_level_search( jpk, gdept_0, & 
    620          & profdata%nvprot(2), profdata%var(2)%vdep, & 
    621          & profdata%var(2)%mvk ) 
     668      ! Only calculated here for z-levels and partial steps.  
     669      ! Otherwise calculated in obs_oper 
     670      !----------------------------------------------------------------------- 
     671      IF ( ln_zco .OR. ln_zps ) THEN 
     672         CALL obs_level_search( jpk, gdept_0, & 
     673            & profdata%nvprot(1), profdata%var(1)%vdep, & 
     674            & profdata%var(1)%mvk ) 
     675         CALL obs_level_search( jpk, gdept_0, & 
     676            & profdata%nvprot(2), profdata%var(2)%vdep, & 
     677            & profdata%var(2)%mvk ) 
     678      ELSE 
     679         profdata%var(1)%mvk = 0 
     680         profdata%var(2)%mvk = 0 
     681      ENDIF    
    622682       
    623683      !----------------------------------------------------------------------- 

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

    r7363 r7367  
    253253         WRITE(numout,*) '               zcorr         = ', zcorr 
    254254         WRITE(numout,*) '               nmsshc        = ', nmsshc 
     255         IF ( nmsshc == 0 ) WRITE(numout,*) '           MSSH correction is not applied' 
     256         IF ( nmsshc == 1 ) WRITE(numout,*) '           MSSH correction is applied' 
     257         IF ( nmsshc == 2 ) WRITE(numout,*) '           User defined MSSH correction'  
    255258      ENDIF 
    256  
    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'  
    260259 
    261260      CALL wrk_dealloc( jpi,jpj, zpromsk ) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_sort.F90

    r7363 r7367  
    2020   PUBLIC sort_dp_indx   ! Get indicies for ascending order for a double prec. array 
    2121   
     22   PUBLIC sort_dp_indx_n ! Get indicies for ascending order for a double prec. array 2D 
    2223   !!---------------------------------------------------------------------- 
    2324   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    6263 
    6364   END SUBROUTINE sort_dp_indx 
     65  
     66   LOGICAL FUNCTION lessn(a,b,n) 
     67      !!---------------------------------------------------------------------- 
     68      !!                    ***  ROUTINE lessn  *** 
     69      !!           
     70      !! ** Purpose : Compare two array and return true if the first 
     71      !!              element of array "a" different from the corresponding  
     72      !!              array "b" element is less than the this element 
     73      !! 
     74      !! ** Method  :  
     75      !! 
     76      !! ** Action  :  
     77      !! 
     78      !! References :  
     79      !! 
     80      !! History : 
     81      !!        !  08-02  (K. Mogensen)  Original code 
     82      !!---------------------------------------------------------------------- 
     83      !! * Arguments 
     84      IMPLICIT NONE 
     85      INTEGER :: n 
     86      REAL(KIND=dp), DIMENSION(n) :: a,b 
     87      INTEGER :: i,j 
     88 
     89      lessn=.FALSE. 
     90      DO i=1,n 
     91         IF (a(i)/=b(i)) THEN 
     92            IF (a(i)<b(i)) THEN 
     93               lessn=.TRUE. 
     94            ELSE 
     95               lessn=.FALSE. 
     96            ENDIF 
     97            EXIT 
     98         ENDIF 
     99      ENDDO 
     100 
     101   END FUNCTION lessn 
     102 
     103   SUBROUTINE  sort_dp_indx_n(pval, n, kindx, kvals) 
     104      !!---------------------------------------------------------------------- 
     105      !!                    ***  ROUTINE index_sort  *** 
     106      !!           
     107      !! ** Purpose : Get indicies for ascending order for a 
     108      !!              double precision array 2D 
     109      !! 
     110      !! ** Method  : Heapsort with call to lessn for comparision 
     111      !! 
     112      !! ** Action  :  
     113      !! 
     114      !! References : http://en.wikipedia.org/wiki/Heapsort 
     115      !! 
     116      !! History : 
     117      !!        !  08-02  (K. Mogensen)  Original code based on index_sort_dp 
     118      !!---------------------------------------------------------------------- 
     119      IMPLICIT NONE 
     120      !! * Arguments 
     121      INTEGER, INTENT(IN) :: n         ! Number of keys 
     122      INTEGER, INTENT(IN) :: kvals     ! Number of values 
     123      REAL(KIND=dp),DIMENSION(n,kvals),INTENT(IN) :: & 
     124         & pval                            ! Array to be sorted 
     125      INTEGER,DIMENSION(kvals),INTENT(INOUT) :: & 
     126         & kindx                           ! Indicies for ordering 
     127      !! * Local variables 
     128      INTEGER :: ji, jj, jt, jn, jparent, jchild 
     129 
     130      DO ji = 1, kvals 
     131         kindx(ji) = ji 
     132      END DO 
     133 
     134      IF (kvals > 1) THEN 
     135 
     136         ji = kvals/2 + 1 
     137         jn = kvals 
     138 
     139         main_loop : DO 
     140 
     141            IF ( ji > 1 ) THEN 
     142               ji = ji-1 
     143               jt = kindx(ji) 
     144            ELSE 
     145               jt = kindx(jn) 
     146               kindx(jn) = kindx(1) 
     147               jn = jn-1 
     148               IF ( jn == 1 ) THEN 
     149                  kindx(1) = jt 
     150                  EXIT main_loop 
     151               ENDIF 
     152            ENDIF 
     153 
     154            jparent = ji 
     155            jchild =  2*ji 
     156 
     157            inner_loop : DO 
     158               IF ( jchild > jn ) EXIT inner_loop 
     159               IF ( jchild < jn ) THEN 
     160                  IF ( lessn(pval(:,kindx(jchild)),pval(:,kindx(jchild+1)),n) ) THEN 
     161                     jchild = jchild+1 
     162                  ENDIF 
     163               ENDIF 
     164               IF  ( lessn(pval(:,jt),pval(:,kindx(jchild)),n) ) THEN 
     165                  kindx(jparent) = kindx(jchild) 
     166                  jparent = jchild 
     167                  jchild = jchild*2 
     168               ELSE  
     169                  jchild = jn + 1  
     170               ENDIF 
     171            ENDDO inner_loop 
     172 
     173            kindx(jparent) = jt 
     174 
     175         END DO  main_loop 
     176      ENDIF 
     177 
     178   END SUBROUTINE sort_dp_indx_n 
     179 
    64180 
    65181   SUBROUTINE index_sort( pval, kindx, kvals ) 

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

    r7363 r7367  
    4848      INTEGER :: nstp       !: Number of time steps 
    4949      INTEGER :: nsurfup    !: Observation counter used in obs_oper 
     50      INTEGER :: nrec       !: Number of surface observation records in window 
    5051 
    5152      ! Arrays with size equal to the number of surface observations 
    … …  
    5455         & mi,   &        !: i-th grid coord. for interpolating to surface observation 
    5556         & mj,   &        !: j-th grid coord. for interpolating to surface observation 
     57         & mt,   &        !: time record number for gridded data 
    5658         & nsidx,&        !: Surface observation number 
    5759         & nsfil,&        !: Surface observation number in file 
    … …  
    7476      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
    7577         & robs, &        !: Surface observation  
    76          & rmod           !: Model counterpart of the surface observation vector 
    77  
     78         & rmod, &        !: Model counterpart of the surface observation vector 
     79         & rstd 
     80          
    7881      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
    7982         & rext           !: Extra fields interpolated to observation points 
    … …  
    8588         & nsstpmpp       !: Global number of surface observations per time step 
    8689 
     90      ! Arrays with size equal to the number of observation records in the window 
     91 
     92      INTEGER, POINTER, DIMENSION(:) :: & 
     93         & mrecstp   ! Time step of the records 
     94 
    8795      ! Arrays used to store source indices when  
    8896      ! compressing obs_surf derived types 
    … …  
    92100      INTEGER, POINTER, DIMENSION(:) :: & 
    93101         & nsind          !: Source indices of surface data in compressed data 
     102 
     103      ! Is this a gridded product? 
     104       
     105      LOGICAL :: lgrid 
    94106 
    95107   END TYPE obs_surf 
    … …  
    137149         & surf%mi(ksurf),      & 
    138150         & surf%mj(ksurf),      & 
     151         & surf%mt(ksurf),      & 
    139152         & surf%nsidx(ksurf),   & 
    140153         & surf%nsfil(ksurf),   & 
    … …  
    153166         & ) 
    154167 
     168      surf%mt(:) = -1 
    155169 
    156170      ! Allocate arrays of number of surface data size * number of variables 
    … …  
    158172      ALLOCATE( &  
    159173         & surf%robs(ksurf,kvar), & 
    160          & surf%rmod(ksurf,kvar)  & 
     174         & surf%rmod(ksurf,kvar),  & 
     175         & surf%rstd(ksurf,kvar)  & 
    161176         & )    
    162177 
    … …  
    166181         & surf%rext(ksurf,kextra) & 
    167182         & ) 
     183 
     184      surf%rext(:,:) = 0.0_wp  
    168185 
    169186      ! Allocate arrays of number of time step size 
    … …  
    188205 
    189206      surf%nsurfup     = 0 
    190                
     207       
     208      ! Not gridded by default 
     209       
     210      surf%lgrid       = .FALSE. 
     211 
    191212   END SUBROUTINE obs_surf_alloc 
    192213 
    … …  
    213234         & surf%mi,      & 
    214235         & surf%mj,      & 
     236         & surf%mt,      & 
    215237         & surf%nsidx,   & 
    216238         & surf%nsfil,   & 
    … …  
    233255      DEALLOCATE( &  
    234256         & surf%robs,    & 
    235          & surf%rmod     & 
     257         & surf%rmod,    & 
     258         & surf%rstd     & 
    236259         & ) 
    237260 
    … …  
    328351            newsurf%mi(insurf)    = surf%mi(ji) 
    329352            newsurf%mj(insurf)    = surf%mj(ji) 
     353            newsurf%mt(insurf)    = surf%mt(ji) 
    330354            newsurf%nsidx(insurf) = surf%nsidx(ji) 
    331355            newsurf%nsfil(insurf) = surf%nsfil(ji) 
    … …  
    346370               newsurf%robs(insurf,jk)  = surf%robs(ji,jk) 
    347371               newsurf%rmod(insurf,jk)  = surf%rmod(ji,jk) 
     372               newsurf%rstd(insurf,jk)  = surf%rstd(ji,jk) 
    348373                
    349374            END DO 
    … …  
    371396 
    372397      newsurf%nstp  = surf%nstp 
     398  
     399      ! Set gridded stuff 
     400 
     401      newsurf%lgrid = surf%lgrid 
    373402  
    374403      ! Deallocate temporary data 
    … …  
    411440         oldsurf%mi(jj)    = surf%mi(ji) 
    412441         oldsurf%mj(jj)    = surf%mj(ji) 
     442         oldsurf%mt(jj)    = surf%mt(ji) 
    413443         oldsurf%nsidx(jj) = surf%nsidx(ji) 
    414444         oldsurf%nsfil(jj) = surf%nsfil(ji) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obs_vel_io.F90

    r7363 r7367  
    1515   USE obs_conv 
    1616   USE in_out_manager 
     17   USE julian 
    1718   USE netcdf 
    1819   IMPLICIT NONE 

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

    r7363 r7367  
    3939      &   obs_wri_sla, &    ! Write SLA observation related diagnostics 
    4040      &   obs_wri_sst, &    ! Write SST observation related diagnostics 
    41       &   obs_wri_sss, &    ! Write SSS observation related diagnostics 
     41!      &   obs_wri_sss &    ! Write SSS observation related diagnostics 
    4242      &   obs_wri_seaice, & ! Write seaice observation related diagnostics 
    4343      &   obs_wri_vel, &    ! Write velocity observation related diagnostics 
    … …  
    468468 
    469469      CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, & 
    470          &                 1 + nadd, next, .TRUE. ) 
     470         &                 2 + nadd, next, .TRUE. ) 
    471471 
    472472      fbdata%cname(1)      = 'SST' 
    … …  
    482482      fbdata%caddunit(1,1) = 'Degree centigrade' 
    483483      fbdata%cgrid(1)      = 'T' 
     484      fbdata%caddname(2)   = 'STD' 
     485      fbdata%caddlong(2,1) = 'Observation STD' 
     486      fbdata%caddunit(2,1) = 'Degree centigrade' 
     487      fbdata%cgrid(2)      = 'T' 
    484488      DO ja = 1, nadd 
    485489         fbdata%caddname(1+ja) = padd%cdname(ja) 
    … …  
    487491         fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 
    488492      END DO 
     493 
     494 
    489495 
    490496      WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 
    … …  
    497503      ENDIF 
    498504 
    499       ! Transform obs_prof data structure into obfbdata structure 
     505      ! Transform obs_sst data structure into obfbdata structure 
    500506      fbdata%cdjuldref = '19500101000000' 
    501507      DO jo = 1, sstdata%nsurf 
    … …  
    519525         fbdata%cdwmo(jo)     = '' 
    520526         fbdata%kindex(jo)    = sstdata%nsfil(jo) 
    521          IF (ln_grid_global) THEN 
     527         IF (ln_grid_global.AND.(.NOT.sstdata%lgrid)) THEN 
    522528            fbdata%iobsi(jo,1) = sstdata%mi(jo) 
    523529            fbdata%iobsj(jo,1) = sstdata%mj(jo) 
    … …  
    535541            &           krefdate = 19500101 ) 
    536542         fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1) 
     543         fbdata%padd(1,jo,2,1) = sstdata%rstd(jo,1) 
    537544         fbdata%pob(1,jo,1)    = sstdata%robs(jo,1) 
    538545         fbdata%pdep(1,jo)     = 0.0 
    … …  
    569576   END SUBROUTINE obs_wri_sst 
    570577 
    571    SUBROUTINE obs_wri_sss 
    572    END SUBROUTINE obs_wri_sss 
    573  
    574578   SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext ) 
    575579      !!----------------------------------------------------------------------- 
    … …  
    586590      !!      ! 07-07  (S. Ricci) Original 
    587591      !!      ! 09-01  (K. Mogensen) New feedback format. 
     592      !!      ! 2011-07 (D. Lea) Change SEAICE to ICECONC 
    588593      !!----------------------------------------------------------------------- 
    589594 
    … …  
    621626      CALL init_obfbdata( fbdata ) 
    622627 
    623       CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. ) 
    624  
    625       fbdata%cname(1)      = 'SEAICE' 
    626       fbdata%coblong(1)    = 'Sea ice' 
     628      CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, & 
     629         &                 1 + nadd, next, .TRUE. ) 
     630 
     631      fbdata%cname(1)      = 'ICECONC' 
     632      fbdata%coblong(1)    = 'Sea ice concentration' 
    627633      fbdata%cobunit(1)    = 'Fraction' 
    628634      DO je = 1, next 

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

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

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

    r7363 r7367  
    6262         z1dm = ( pdep(kkco(jdep)) - pobsdep(jdep)      ) 
    6363         z1dp = ( pobsdep(jdep)    - pdep(kkco(jdep)-1) ) 
    64          IF ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp 
    65  
     64         IF ( pobsmask(kkco(jdep)) == 0.0_wp ) THEN 
     65            pobs(jdep) = pobsk(kkco(jdep)-1) 
     66            CYCLE 
     67         ENDIF 
     68          
    6669         zsum = z1dm + z1dp 
    6770          

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obssla_types.h90

    r7363 r7367  
    55   !!---------------------------------------------------------------------- 
    66 
    7    INTEGER, PARAMETER :: imaxmissions=8 
     7   INTEGER, PARAMETER :: imaxmissions=10 
    88   CHARACTER(len=3) :: cmissions(0:imaxmissions) = & 
    9       & (/ 'XXX', 'E1 ', 'E2 ', 'TP ', 'TPM', 'G2 ', 'J1 ', 'EN ', 'J2 ' /) 
     9      & (/ 'XXX', 'E1 ', 'E2 ', 'TP ', 'TPN', 'G2 ', 'J1 ', 'EN ', 'J2 ','J1N','ENN' /) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/OBS/obsvel_io.h90

    r7363 r7367  
    290290      END DO 
    291291 
    292       ! No position, time, depth and variable QC in input files 
     292      ! No observation, position, time, depth and variable QC in input files 
    293293      DO jo = 1, iobs 
     294         inpfile%ioqc(jo) = 1 
    294295         inpfile%ipqc(jo) = 1 
    295296         inpfile%itqc(jo) = 1 
    … …  
    359360 
    360361   END SUBROUTINE read_taondbc 
     362 
     363   SUBROUTINE read_adcpwoce( cdfilename, inpfile, kunit, ldwp, ldgrid ) 
     364      !!--------------------------------------------------------------------- 
     365      !! 
     366      !!                     ** ROUTINE read_adcpwoce ** 
     367      !! 
     368      !! ** Purpose : Read from file the ADCP data from WOCe. 
     369      !! 
     370      !! ** Method  : The data file is a NetCDF file.  
     371      !! 
     372      !! ** Action  : 
     373      !! 
     374      !! ** Reference : http://ilikai.soest.hawaii.edu/sadcp/main_inv.html 
     375      !! History :  
     376      !!          ! 10-05 (K. Mogensen) Original version. 
     377      !!---------------------------------------------------------------------- 
     378      !! * Arguments 
     379      CHARACTER(LEN=*) :: cdfilename ! Input filename 
     380      TYPE(obfbdata)   :: inpfile    ! Output obfbdata structure 
     381      INTEGER          :: kunit      ! Unit for output 
     382      LOGICAL          :: ldwp       ! Print info 
     383      LOGICAL          :: ldgrid     ! Save grid info in data structure 
     384      !! * Local declarations 
     385      INTEGER  :: & 
     386         & iobs, &                   ! Number of observations 
     387         & ilev, &                   ! Number of levels 
     388         & ilat, &                   ! Number of latitudes 
     389         & ilon, &                   ! Number of longtudes 
     390         & itim                      ! Number of obs. times 
     391      INTEGER :: & 
     392         & i_file_id,                & 
     393         & i_dimid_id,               & 
     394         & i_phi_id,                 &  
     395         & i_lam_id,                 & 
     396         & i_depth_id,               & 
     397         & i_var_id,                 & 
     398         & i_date_id,                & 
     399         & i_time_id 
     400      CHARACTER(LEN=40) :: &  
     401         & cl_fld_lam,                 & 
     402         & cl_fld_phi,                 & 
     403         & cl_fld_depth,               & 
     404         & cl_fld_var_u,               & 
     405         & cl_fld_var_v,               & 
     406         & cl_fld_date,                & 
     407         & cl_fld_time 
     408      INTEGER :: & 
     409         & ja, & 
     410         & jo, & 
     411         & jk, & 
     412         & jt 
     413      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: & 
     414         & zv, & 
     415         & zu 
     416      REAL(wp), ALLOCATABLE, DIMENSION(:) :: & 
     417         & zdep, & 
     418         & zlat, & 
     419         & zlon, & 
     420         & ztime,&  
     421         & zjuld 
     422      INTEGER, ALLOCATABLE, DIMENSION(:) :: & 
     423         & idate 
     424      CHARACTER(LEN=50) :: & 
     425         & cdjulref 
     426      INTEGER :: & 
     427         & iyr, & 
     428         & imo, & 
     429         & ida, & 
     430         & iti, & 
     431         & iho, & 
     432         & imi, & 
     433         & ise 
     434      CHARACTER(LEN=13), PARAMETER :: & 
     435         & cl_name = 'read_adcpwoce' 
     436      INTEGER :: & 
     437         & inam 
     438      INTEGER, PARAMETER :: & 
     439         & imaxnam = 128 
     440      CHARACTER(len=imaxnam) :: & 
     441         & clcrnum 
     442 
     443      !----------------------------------------------------------------------- 
     444      ! Initialization 
     445      !----------------------------------------------------------------------- 
     446      cl_fld_lam                 = 'longitude' 
     447      cl_fld_phi                 = 'latitude' 
     448      cl_fld_depth               = 'depth' 
     449      cl_fld_date                = 'woce_date' 
     450      cl_fld_time                = 'woce_time' 
     451      cl_fld_var_u               = 'u' 
     452      cl_fld_var_v               = 'v' 
     453 
     454      !----------------------------------------------------------------------- 
     455      ! Open file 
     456      !----------------------------------------------------------------------- 
     457 
     458      CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, & 
     459            &      i_file_id ),           cl_name, __LINE__ ) 
     460 
     461      !----------------------------------------------------------------------- 
     462      ! Read the heading of the file 
     463      !----------------------------------------------------------------------- 
     464      IF(ldwp) WRITE(kunit,*) 
     465      IF(ldwp) WRITE(kunit,*) ' read_adcpwoce :'  
     466      IF(ldwp) WRITE(kunit,*) ' ~~~~~~~~~~~~~~~' 
     467       
     468      !--------------------------------------------------------------------- 
     469      ! Read the number of observations and of levels to allocate array 
     470      !--------------------------------------------------------------------- 
     471      CALL chkerr( nf90_inq_dimid        ( i_file_id, 'time', i_dimid_id ),        & 
     472         &         cl_name, __LINE__ ) 
     473      CALL chkerr( nf90_inquire_dimension( i_file_id, i_dimid_id, len = itim ),    & 
     474         &         cl_name, __LINE__ ) 
     475      CALL chkerr( nf90_inq_dimid        ( i_file_id, 'depth', i_dimid_id ),       & 
     476         &         cl_name, __LINE__ ) 
     477      CALL chkerr( nf90_inquire_dimension( i_file_id, i_dimid_id, len = ilev ),    & 
     478         &         cl_name, __LINE__ ) 
     479      iobs = itim 
     480      IF(ldwp)WRITE(kunit,*) '         No. of data records = ', iobs 
     481      IF(ldwp)WRITE(kunit,*) '         No. of levels       = ', ilev 
     482      IF(ldwp)WRITE(kunit,*)  
     483 
     484      !--------------------------------------------------------------------- 
     485      ! Allocate arrays 
     486      !--------------------------------------------------------------------- 
     487 
     488      CALL init_obfbdata( inpfile ) 
     489      CALL alloc_obfbdata( inpfile, 2, iobs, ilev, 0, 0, ldgrid ) 
     490      inpfile%cname(1) = 'UVEL' 
     491      inpfile%cname(2) = 'VVEL' 
     492      inpfile%coblong(1) = 'Zonal current' 
     493      inpfile%coblong(2) = 'Meridional current' 
     494      inpfile%cobunit(1) = 'Meters per second' 
     495      inpfile%cobunit(2) = 'Meters per second' 
     496 
     497      ALLOCATE( & 
     498         & zu(ilev,itim),     & 
     499         & zv(ilev,itim),     & 
     500         & zdep(ilev),        & 
     501         & idate(itim),       & 
     502         & ztime(itim),       & 
     503         & zlat(itim),        & 
     504         & zlon(itim),        & 
     505         & zjuld(itim)        & 
     506         & ) 
     507 
     508      !--------------------------------------------------------------------- 
     509      ! Read the time/position variables  
     510      !--------------------------------------------------------------------- 
     511        
     512      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_date, i_date_id ),   & 
     513         &         cl_name, __LINE__ ) 
     514      CALL chkerr( nf90_get_var  ( i_file_id, i_date_id, idate ),         & 
     515         &         cl_name, __LINE__ ) 
     516 
     517      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_time, i_time_id ),   & 
     518         &         cl_name, __LINE__ ) 
     519      CALL chkerr( nf90_get_var  ( i_file_id, i_time_id, ztime ),         & 
     520         &         cl_name, __LINE__ ) 
     521 
     522       
     523      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_depth, i_depth_id ), & 
     524            &         cl_name, __LINE__ )          
     525      CALL chkerr( nf90_get_var  ( i_file_id, i_depth_id, zdep ),         & 
     526         &         cl_name, __LINE__ ) 
     527       
     528      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_phi, i_phi_id ),     & 
     529         &         cl_name, __LINE__ ) 
     530      CALL chkerr( nf90_get_var  ( i_file_id, i_phi_id, zlat ),           & 
     531         &         cl_name, __LINE__ ) 
     532       
     533      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_lam, i_lam_id ),     & 
     534         &         cl_name, __LINE__ ) 
     535      CALL chkerr( nf90_get_var  ( i_file_id, i_lam_id, zlon ),           & 
     536         &         cl_name, __LINE__ ) 
     537       
     538      !--------------------------------------------------------------------- 
     539      ! Read the variables 
     540      !--------------------------------------------------------------------- 
     541 
     542      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_u, i_var_id ),   & 
     543         &         cl_name, __LINE__ ) 
     544      CALL chkerr( nf90_get_var  ( i_file_id, i_var_id, zu ),             & 
     545         &         cl_name, __LINE__ ) 
     546 
     547      CALL chkerr( nf90_inq_varid( i_file_id, cl_fld_var_v, i_var_id ),   & 
     548         &         cl_name, __LINE__ ) 
     549      CALL chkerr( nf90_get_var  ( i_file_id, i_var_id, zv ),             & 
     550         &         cl_name, __LINE__ ) 
     551 
     552      !--------------------------------------------------------------------- 
     553      ! Get Cruise number 
     554      !--------------------------------------------------------------------- 
     555 
     556      CALL chkerr ( nf90_inquire_attribute( i_file_id, nf90_global,       & 
     557         &                                  'DAC_ID', len = inam ),       & 
     558         &          cl_name, __LINE__ ) 
     559      IF ( inam > imaxnam ) THEN 
     560         CALL fatal_error( 'Error retrieving cruise in read_adcpwoce',    & 
     561            &              __LINE__ ) 
     562      ENDIF 
     563      CALL chkerr ( nf90_get_att( i_file_id, nf90_global,                 & 
     564         &                        'DAC_ID', clcrnum ),                    & 
     565         &          cl_name, __LINE__ ) 
     566      clcrnum=TRIM(ADJUSTL(clcrnum)) 
     567       
     568      !--------------------------------------------------------------------- 
     569      ! Close file 
     570      !--------------------------------------------------------------------- 
     571 
     572      CALL chkerr( nf90_close( i_file_id ),           cl_name, __LINE__ ) 
     573 
     574      !--------------------------------------------------------------------- 
     575      ! Convert to to 19500101 based Julian date 
     576      !--------------------------------------------------------------------- 
     577 
     578      DO jt = 1, itim 
     579         iyr = idate(jt)/10000 
     580         imo = MOD(idate(jt)/100,100) 
     581         ida = MOD(idate(jt),100) 
     582         iti = INT(ztime(jt)) 
     583         iho = iti/10000 
     584         imi = MOD(iti/100,100) 
     585         ise = MOD(iti,100) 
     586         CALL greg2jul( ise, imi, iho, ida, imo, iyr, zjuld(jt) ) 
     587      ENDDO 
     588      inpfile%cdjuldref = '19500101000000' 
     589 
     590      !--------------------------------------------------------------------- 
     591      ! Copy info to obfbdata structure 
     592      !--------------------------------------------------------------------- 
     593 
     594      DO jo = 1, iobs 
     595         inpfile%cdwmo(jo) = clcrnum(1:ilenwmo) 
     596         DO jk = 1, ilev 
     597            inpfile%pob(jk,jo,1)     = zu(jk,jo) 
     598            inpfile%pob(jk,jo,2)     = zv(jk,jo) 
     599            inpfile%pdep(jk,jo)      = zdep(jk) 
     600         ENDDO 
     601         inpfile%plam(jo) = zlon(jo) 
     602         inpfile%pphi(jo) = zlat(jo) 
     603         inpfile%ptim(jo) = zjuld(jo) 
     604      ENDDO 
     605 
     606      ! No position, time, depth and variable QC in input files 
     607      DO jo = 1, iobs 
     608         inpfile%ipqc(jo) = 1 
     609         inpfile%ioqc(jo) = 1 
     610         inpfile%itqc(jo) = 1 
     611         inpfile%ivqc(jo,1:2) = 1 
     612         DO jk = 1, ilev 
     613            inpfile%idqc(jk,jo) = 1 
     614            inpfile%ivlqc(jk,jo,1:2) = 1 
     615         ENDDO 
     616      ENDDO 
     617 
     618      !--------------------------------------------------------------------- 
     619      ! Set the platform information 
     620      !--------------------------------------------------------------------- 
     621      inpfile%cdtyp(:)='1023' 
     622 
     623      !--------------------------------------------------------------------- 
     624      ! Set QC flags for missing data and rescale to m/s 
     625      !--------------------------------------------------------------------- 
     626 
     627      DO jo = 1, iobs 
     628         IF ( ( ABS(inpfile%plam(jo)) > 10000.0_wp ) .OR. & 
     629            & ( ABS(inpfile%pphi(jo)) > 10000.0_wp ) ) THEN 
     630            inpfile%ipqc(jo) = 4 
     631            inpfile%ioqc(jo) = 4 
     632            inpfile%itqc(jo) = 4 
     633            inpfile%ivqc(jo,1:2) = 4 
     634         ENDIF 
     635         DO jk = 1, ilev 
     636            IF ( ( ABS(inpfile%pob(jk,jo,1)) > 10000.0_wp ) .OR. & 
     637               & ( ABS(inpfile%pob(jk,jo,2)) > 10000.0_wp ) ) THEN 
     638               inpfile%ivlqc(jk,jo,:) = 4 
     639               inpfile%pob(jk,jo,1) = fbrmdi 
     640               inpfile%pob(jk,jo,2) = fbrmdi 
     641            ENDIF 
     642         ENDDO 
     643      ENDDO 
     644 
     645      !--------------------------------------------------------------------- 
     646      ! Set file indexes 
     647      !--------------------------------------------------------------------- 
     648 
     649      DO jo = 1, inpfile%nobs 
     650         inpfile%kindex(jo) = jo 
     651      ENDDO 
     652 
     653      !--------------------------------------------------------------------- 
     654      ! Initialize flags since they are not in the TAO input files 
     655      !--------------------------------------------------------------------- 
     656 
     657      inpfile%ioqcf(:,:)      = 0 
     658      inpfile%ipqcf(:,:)      = 0 
     659      inpfile%itqcf(:,:)      = 0 
     660      inpfile%idqcf(:,:,:)    = 0 
     661      inpfile%ivqcf(:,:,:)    = 0 
     662      inpfile%ivlqcf(:,:,:,:) = 0 
     663 
     664      !--------------------------------------------------------------------- 
     665      ! Deallocate data 
     666      !--------------------------------------------------------------------- 
     667 
     668      DEALLOCATE( & 
     669         & zu,     & 
     670         & zv,     & 
     671         & zdep,   & 
     672         & idate,  & 
     673         & ztime,  & 
     674         & zlat,   & 
     675         & zlon,   & 
     676         & zjuld   & 
     677         & ) 
     678 
     679   END SUBROUTINE read_adcpwoce 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r7363 r7367  
    7070   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tprecip           !: total precipitation                          [Kg/m2/s] 
    7171   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sprecip           !: solid precipitation                          [Kg/m2/s] 
     72   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   pressnow  !: UKMO SHELF pressure  
     73   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   apgu      !: UKMO SHELF pressure forcing  
     74   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   apgv      !: UKMO SHELF pressure forcing  
    7275   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fr_i              !: ice fraction = 1 - lead fraction      (between 0 to 1) 
    7376#if defined key_cpl_carbon_cycle 
    … …  
    114117         ! 
    115118      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     & 
     119         &      pressnow(jpi,jpj), apgu(jpi,jpj)    , apgv(jpi,jpj) ,     & 
    116120#if defined key_cpl_carbon_cycle 
    117121         &      atm_co2(jpi,jpj) ,                                        & 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90

    r7363 r7367  
    2727   PUBLIC   sbc_apr    ! routine called in sbcmod 
    2828    
    29    !                                         !!* namsbc_apr namelist (Atmospheric PRessure) * 
    30    LOGICAL, PUBLIC ::   ln_apr_obc = .FALSE.  !: inverse barometer added to OBC ssh data  
    31    LOGICAL, PUBLIC ::   ln_ref_apr = .FALSE.  !: ref. pressure: global mean Patm (F) or a constant (F) 
     29   !                                              !!* namsbc_apr namelist (Atmospheric PRessure) * 
     30   LOGICAL, PUBLIC ::   ln_apr_obc = .FALSE.      !: inverse barometer added to OBC ssh data  
     31   LOGICAL, PUBLIC ::   ln_ref_apr = .FALSE.      !: ref. pressure: global mean Patm (F) or a constant (F) 
     32   REAL(wp)        ::   rn_pref    = 101000._wp   !  reference atmospheric pressure   [N/m2] 
    3233 
    3334   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   ssh_ib    ! Inverse barometer now    sea surface height   [m] 
    … …  
    3536   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   apr       ! atmospheric pressure at kt                 [N/m2] 
    3637    
    37    REAL(wp) ::   rpref = 101000._wp   ! reference atmospheric pressure          [N/m2] 
    3838   REAL(wp) ::   tarea                ! whole domain mean masked ocean surface 
    3939   REAL(wp) ::   r1_grau              ! = 1.e0 / (grav * rau0) 
    … …  
    6666      !! 
    6767      INTEGER            ::   ierror  ! local integer  
    68       REAL(wp)           ::   zpref   ! local scalar 
    6968      !! 
    7069      CHARACTER(len=100) ::  cn_dir   ! Root directory for location of ssr files 
    7170      TYPE(FLD_N)        ::  sn_apr   ! informations about the fields to be read 
    7271      !! 
    73       NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr 
     72      NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc 
    7473      !!---------------------------------------------------------------------- 
    7574      ! 
    … …  
    104103         ! 
    105104         IF( ln_ref_apr ) THEN                        !* Compute whole inner domain mean masked ocean surface 
    106             tarea = glob_sum( e1t(:,:) * e2t(:,:) ) 
     105            tarea = glob_sum( e1e2t(:,:) ) 
    107106            IF(lwp) WRITE(numout,*) '         Variable ref. Patm computed over a ocean surface of ', tarea*1e-6, 'km2' 
    108107         ELSE 
    109             IF(lwp) WRITE(numout,*) '         Reference Patm used : ', rpref, ' N/m2' 
     108            IF(lwp) WRITE(numout,*) '         Reference Patm used : ', rn_pref, ' N/m2' 
    110109         ENDIF 
    111110         ! 
    … …  
    113112         ! 
    114113         !                                            !* control check 
    115          IF( ln_apr_obc  )   & 
    116             CALL ctl_stop( 'sbc_apr: inverse barometer added to OBC ssh data not yet implemented ' ) 
    117          IF( ln_apr_obc .AND. .NOT. lk_obc )   & 
    118             CALL ctl_stop( 'sbc_apr: add inverse barometer to OBC requires to use key_obc' ) 
     114         IF ( ln_apr_obc  ) THEN 
     115            IF(lwp) WRITE(numout,*) '         Inverse barometer added to OBC ssh data' 
     116         ENDIF 
    119117         IF( ( ln_apr_obc ) .AND. .NOT. lk_dynspg_ts )   & 
    120118            CALL ctl_stop( 'sbc_apr: use inverse barometer ssh at open boundary ONLY possible with time-splitting' ) 
    … …  
    132130         ! 
    133131         !                                                  !* update the reference atmospheric pressure (if necessary) 
    134          IF( ln_ref_apr )   rpref = glob_sum( sf_apr(1)%fnow(:,:,1) * e1t(:,:) * e2t(:,:) ) / tarea 
     132         IF( ln_ref_apr )   rn_pref = glob_sum( sf_apr(1)%fnow(:,:,1) * e1e2t(:,:) ) / tarea 
    135133         ! 
    136134         !                                                  !* Patm related forcing at kt 
    137          ssh_ib(:,:) = - ( sf_apr(1)%fnow(:,:,1) - rpref ) * r1_grau    ! equivalent ssh (inverse barometer) 
     135         ssh_ib(:,:) = - ( sf_apr(1)%fnow(:,:,1) - rn_pref ) * r1_grau    ! equivalent ssh (inverse barometer) 
    138136         apr   (:,:) =     sf_apr(1)%fnow(:,:,1)                        ! atmospheric pressure 
    139137         ! 
    140          CALL iom_put( "ssh_ib", ssh_ib )                   !* output the inverse barometer ssh 
     138!         CALL iom_put( "ssh_ib", ssh_ib )                   !* output the inverse barometer ssh 
    141139      ENDIF 
    142140 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r7363 r7367  
    721721               !                                                       ! (geographical to local grid -> rotate the components) 
    722722               CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx )    
    723                frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid 
    724723               IF( srcv(jpr_otx2)%laction ) THEN 
    725724                  CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty )    
    … …  
    727726                  CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty )   
    728727               ENDIF 
     728               frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid 
    729729               frcv(jpr_oty1)%z3(:,:,1) = zty(:,:)      ! overwrite 2nd component on the 2nd grid 
    730730            ENDIF 
    … …  
    949949               !                                                       ! (geographical to local grid -> rotate the components) 
    950950               CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx )    
    951                frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid 
    952951               IF( srcv(jpr_itx2)%laction ) THEN 
    953952                  CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty )    
    … …  
    955954                  CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty )   
    956955               ENDIF 
     956               frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:)      ! overwrite 1st component on the 1st grid 
    957957               frcv(jpr_ity1)%z3(:,:,1) = zty(:,:)      ! overwrite 2nd component on the 1st grid 
    958958            ENDIF 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbcflx.F90

    r7363 r7367  
    2828   PUBLIC sbc_flx       ! routine called by step.F90 
    2929 
    30    INTEGER , PARAMETER ::   jpfld   = 5   ! maximum number of files to read  
     30   INTEGER , PARAMETER ::   jpfld   = 6   ! maximum number of files to read  
    3131   INTEGER , PARAMETER ::   jp_utau = 1   ! index of wind stress (i-component) file 
    3232   INTEGER , PARAMETER ::   jp_vtau = 2   ! index of wind stress (j-component) file 
    … …  
    3434   INTEGER , PARAMETER ::   jp_qsr  = 4   ! index of solar heat file 
    3535   INTEGER , PARAMETER ::   jp_emp  = 5   ! index of evaporation-precipation file 
     36   INTEGER , PARAMETER ::   jp_press = 6  ! index of pressure for UKMO shelf fluxes 
    3637   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf    ! structure of input fields (file informations, fields read) 
     38   LOGICAL , PUBLIC    ::   ln_shelf_flx = .FALSE. ! UKMO SHELF specific flux flag   
     39   INTEGER             ::   jpfld_local   ! maximum number of files to read (locally modified depending on ln_shelf_flx)  
    3740 
    3841   !! * Substitutions 
    … …  
    7982      REAL(wp) ::   zcdrag = 1.5e-3       ! drag coefficient 
    8083      REAL(wp) ::   ztx, zty, zmod, zcoef ! temporary variables 
     84      REAL     ::   cs           ! UKMO SHELF: Friction co-efficient at surface  
     85      REAL     ::   totwindspd   ! UKMO SHELF: Magnitude of wind speed vector  
     86  
     87      REAL(wp) ::   rhoa  = 1.22         ! Air density kg/m3  
     88      REAL(wp) ::   cdrag = 1.5e-3       ! drag coefficient  
    8189      !! 
    8290      CHARACTER(len=100) ::  cn_dir                               ! Root directory for location of flx files 
    8391      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i                    ! array of namelist information structures 
    84       TYPE(FLD_N) ::   sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp  ! informations about the fields to be read 
    85       NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp 
     92      TYPE(FLD_N) ::   sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp, sn_press  ! informations about the fields to be read 
     93      LOGICAL     ::   ln_foam_flx  = .FALSE.                     ! UKMO FOAM specific flux flag 
     94      NAMELIST/namsbc_flx/ cn_dir     , sn_utau , sn_vtau      , sn_qtot, sn_qsr, sn_emp,   & 
     95         &                 ln_foam_flx, sn_press, ln_shelf_flx 
    8696      !!--------------------------------------------------------------------- 
    8797      ! 
    … …  
    97107         sn_qsr  = FLD_N(  'qsr'  ,    24     ,  'qsr'     ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    98108         sn_emp  = FLD_N(  'emp'  ,    24     ,  'emp'     ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
     109         sn_press= FLD_N(  'p_msl',    24     ,  'p_msl'   ,  .false.   , .false. ,   'yearly'  , ''       , ''        ) 
    99110         ! 
    100111         REWIND ( numnam )                         ! read in namlist namflx 
    … …  
    109120         slf_i(jp_qtot) = sn_qtot   ;   slf_i(jp_qsr ) = sn_qsr  
    110121         slf_i(jp_emp ) = sn_emp 
    111          ! 
    112          ALLOCATE( sf(jpfld), STAT=ierror )        ! set sf structure 
     122         IF( ln_shelf_flx ) slf_i(jp_press) = sn_press  
     123  
     124         ! define local jpfld depending on shelf_flx logical  
     125         IF( ln_shelf_flx ) THEN  
     126            jpfld_local = jpfld  
     127         ELSE  
     128            jpfld_local = jpfld-1  
     129         ENDIF  
     130         ! 
     131         ALLOCATE( sf(jpfld_local), STAT=ierror )        ! set sf structure 
    113132         IF( ierror > 0 ) THEN    
    114133            CALL ctl_stop( 'sbc_flx: unable to allocate sf structure' )   ;   RETURN   
    … …  
    131150         ENDIF 
    132151!CDIR COLLAPSE 
     152  
     153         !!UKMO SHELF effect of atmospheric pressure on SSH  
     154         IF( ln_shelf_flx ) THEN  
     155            DO jj = 1, jpjm1  
     156               DO ji = 1, jpim1  
     157                  apgu(ji,jj) = (-1.0/rau0)*(sf(jp_press)%fnow(ji+1,jj,1)-sf(jp_press)%fnow(ji,jj,1))/e1u(ji,jj)  
     158                  apgv(ji,jj) = (-1.0/rau0)*(sf(jp_press)%fnow(ji,jj+1,1)-sf(jp_press)%fnow(ji,jj,1))/e2v(ji,jj)  
     159               END DO  
     160            END DO  
     161         ENDIF ! ln_shelf_flx  
     162  
    133163         DO jj = 1, jpj                                           ! set the ocean fluxes from read fields 
    134164            DO ji = 1, jpi 
    135                utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) 
    136                vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) 
    137                qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) 
    138                emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) 
     165               IF( ln_shelf_flx ) THEN  
     166                  !! UKMO SHELF - need atmospheric pressure to calculate Haney forcing  
     167                  pressnow(ji,jj) = sf(jp_press)%fnow(ji,jj,1)  
     168                  !! UKMO SHELF flux files contain wind speed not wind stress  
     169                  totwindspd = sqrt((sf(jp_utau)%fnow(ji,jj,1))**2.0 + (sf(jp_vtau)%fnow(ji,jj,1))**2.0)  
     170                  cs = 0.63 + (0.066 * totwindspd)  
     171                  utau(ji,jj) = cs * (rhoa/rau0) * sf(jp_utau)%fnow(ji,jj,1) * totwindspd  
     172                  vtau(ji,jj) = cs * (rhoa/rau0) * sf(jp_vtau)%fnow(ji,jj,1) * totwindspd  
     173               ELSE  
     174                  utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1)  
     175                  vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1)  
     176               ENDIF  
     177               qsr (ji,jj) = sf(jp_qsr )%fnow(ji,jj,1)  
     178               IF( ln_foam_flx .OR. ln_shelf_flx ) THEN  
     179                  !! UKMO FOAM flux files contain non-solar heat flux (qns) rather than total heat flux (qtot)   
     180                  qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1)   
     181                  !! UKMO FOAM flux files contain the net DOWNWARD freshwater flux P-E rather then E-P   
     182                  emp (ji,jj) = -1. * sf(jp_emp )%fnow(ji,jj,1)   
     183               ELSE  
     184                  qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1)  
     185                  emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1)  
     186               ENDIF  
    139187            END DO 
    140188         END DO 
     189 
     190         !! UKMO FOAM wind fluxes need lbc_lnk calls owing to a bug in interp.exe   
     191         IF( ln_foam_flx ) THEN  
     192            CALL lbc_lnk( utau(:,:), 'U', -1. )   
     193            CALL lbc_lnk( vtau(:,:), 'V', -1. )   
     194         ENDIF   
     195  
    141196         !                                                        ! module of wind stress and wind speed at T-point 
    142197         zcoef = 1. / ( zrhoa * zcdrag ) 
    … …  
    159214            WRITE(numout,*)  
    160215            WRITE(numout,*) '        read daily momentum, heat and freshwater fluxes OK' 
    161             DO jf = 1, jpfld 
     216            DO jf = 1, jpfld_local 
    162217               IF( jf == jp_utau .OR. jf == jp_vtau )   zfact =     1. 
    163218               IF( jf == jp_qtot .OR. jf == jp_qsr  )   zfact =     0.1 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r7363 r7367  
    272272      !                                            !==  Misc. Options  ==! 
    273273       
    274       SELECT CASE( nn_ice )                                     ! Update heat and freshwater fluxes over sea-ice areas 
    275       CASE(  1 )   ;       CALL sbc_ice_if   ( kt )                  ! Ice-cover climatology ("Ice-if" model) 
    276          !                                                       
    277       CASE(  2 )   ;       CALL sbc_ice_lim_2( kt, nsbc )            ! LIM-2 ice model 
    278          IF( lk_bdy )      CALL bdy_ice_lim_2( kt )                  ! BDY boundary condition 
    279          !                                                      
    280       CASE(  3 )   ;       CALL sbc_ice_lim  ( kt, nsbc )            ! LIM-3 ice model 
    281          ! 
    282       CASE(  4 )   ;       CALL sbc_ice_cice ( kt, nsbc )            ! CICE ice model 
     274      SELECT CASE( nn_ice )                                       ! Update heat and freshwater fluxes over sea-ice areas 
     275      CASE(  1 )   ;         CALL sbc_ice_if   ( kt )                ! Ice-cover climatology ("Ice-if" model) 
     276      CASE(  2 )   ;         CALL sbc_ice_lim_2( kt, nsbc )          ! LIM-2 ice model 
     277              IF( lk_bdy )   CALL bdy_ice_lim_2( kt )                ! BDY boundary condition 
     278      CASE(  3 )   ;         CALL sbc_ice_lim  ( kt, nsbc )          ! LIM-3 ice model 
     279      CASE(  4 )   ;         CALL sbc_ice_cice ( kt, nsbc )          ! CICE ice model 
    283280      END SELECT                                               
    284281 
    285       IF( ln_rnf       )   CALL sbc_rnf( kt )                   ! add runoffs to fresh water fluxes 
     282      IF( ln_rnf         )   CALL sbc_rnf( kt )                   ! add runoffs to fresh water fluxes 
    286283  
    287       IF( ln_ssr       )   CALL sbc_ssr( kt )                   ! add SST/SSS damping term 
    288  
    289       IF( nn_fwb  /= 0 )   CALL sbc_fwb( kt, nn_fwb, nn_fsbc )  ! control the freshwater budget 
    290  
    291       IF( nclosea == 1 )   CALL sbc_clo( kt )                   ! treatment of closed sea in the model domain  
    292       !                                                         ! (update freshwater fluxes) 
     284      IF( ln_ssr         )   CALL sbc_ssr( kt )                   ! add SST/SSS damping term 
     285 
     286      IF( nn_fwb    /= 0 )   CALL sbc_fwb( kt, nn_fwb, nn_fsbc )  ! control the freshwater budget 
     287 
     288      IF( nn_closea == 1 )   CALL sbc_clo( kt )                   ! treatment of closed sea in the model domain  
     289      !                                                           ! (update freshwater fluxes) 
    293290!RBbug do not understand why see ticket 667 
    294291      CALL lbc_lnk( emp, 'T', 1. ) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r7363 r7367  
    1616   !!   rnf_mouth    : set river mouth mask 
    1717   !!---------------------------------------------------------------------- 
     18   USE oce             ! ocean dynamics and tracers variables 
    1819   USE dom_oce         ! ocean space and time domain 
    1920   USE phycst          ! physical constants 
    … …  
    5455   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   h_rnf               !: depth of runoff in m 
    5556   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf              !: depth of runoff in model levels 
    56    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s] 
     57   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s] 
    5758    
    5859   REAL(wp) ::   r1_rau0   ! = 1 / rau0  
    … …  
    7778      ALLOCATE( rnfmsk(jpi,jpj)         , rnfmsk_z(jpk)          ,     & 
    7879         &      h_rnf (jpi,jpj)         , nk_rnf  (jpi,jpj)      ,     & 
    79          &      rnf_tsc_b(jpi,jpj,jpts) , rnf_tsc (jpi,jpj,jpts) , STAT=sbc_rnf_alloc ) 
     80         &      rnf_tsc_b(jpi,jpj,jpk,jpts) , rnf_tsc (jpi,jpj,jpk,jpts) , STAT=sbc_rnf_alloc ) 
    8081         ! 
    8182      IF( lk_mpp            )   CALL mpp_sum ( sbc_rnf_alloc ) 
    … …  
    9798      INTEGER, INTENT(in) ::   kt          ! ocean time step 
    9899      !! 
    99       INTEGER  ::   ji, jj   ! dummy loop indices 
     100      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    100101      !!---------------------------------------------------------------------- 
    101102      !                                    
    … …  
    106107         !                                         ! ---------------------------------------- ! 
    107108         rnf_b    (:,:  ) = rnf    (:,:  )               ! Swap the ocean forcing fields except at nit000 
    108          rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
     109         rnf_tsc_b(:,:,:,:) = rnf_tsc(:,:,:,:)               ! where before fields are set at the end of the routine 
    109110         ! 
    110111      ENDIF 
    … …  
    131132            r1_rau0 = 1._wp / rau0 
    132133            !                                                     ! set temperature & salinity content of runoffs 
    133             IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
    134                rnf_tsc(:,:,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    135                WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999 )                 ! if missing data value use SST as runoffs temperature   
    136                    rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    137                END WHERE 
    138             ELSE                                                        ! use SST as runoffs temperature 
    139                rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    140             ENDIF   
    141             !                                                           ! use runoffs salinity data  
    142             IF( ln_rnf_sal )   rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
    143             !                                                           ! else use S=0 for runoffs (done one for all in the init) 
    144             ! 
    145             IF( ln_rnf_tem .OR. ln_rnf_sal ) THEN                 ! runoffs as outflow: use ocean SST and SSS 
    146                WHERE( rnf(:,:) < 0._wp )                                 ! example baltic model when flow is out of domain  
    147                   rnf_tsc(:,:,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
    148                   rnf_tsc(:,:,jp_sal) = sss_m(:,:) * rnf(:,:) * r1_rau0 
    149                END WHERE 
    150             ENDIF 
    151             ! 
     134            DO  jk=1,jpk 
     135               IF( ln_rnf_tem ) THEN                                       ! use runoffs temperature data 
     136                  rnf_tsc(:,:,jk,jp_tem) = ( sf_t_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     137                  WHERE( sf_t_rnf(1)%fnow(:,:,1) == -999 )                 ! if missing data value use SST as runoffs temperature   
     138                      rnf_tsc(:,:,jk,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
     139                  END WHERE 
     140               ELSE                                                        ! use SST as runoffs temperature 
     141                  rnf_tsc(:,:,jk,jp_tem) = sst_m(:,:) * rnf(:,:) * r1_rau0 
     142               ENDIF   
     143               !                                                           ! use runoffs salinity data  
     144               IF( ln_rnf_sal )   rnf_tsc(:,:,jk,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 
     145               !                                                           ! else use S=0 for runoffs (done one for all in the init) 
     146               ! 
     147               IF( ln_rnf_tem .OR. ln_rnf_sal ) THEN                 ! runoffs as outflow: Must Use 3D T,S 
     148                  WHERE( rnf(:,:) < 0._wp )                                 ! example baltic model when flow is out of domain  
     149                     rnf_tsc(:,:,jk,jp_tem) = tsn(:,:,jk,jp_tem) * rnf(:,:) * r1_rau0 
     150                     rnf_tsc(:,:,jk,jp_sal) = tsn(:,:,jk,jp_sal) * rnf(:,:) * r1_rau0 
     151                  END WHERE 
     152               ENDIF 
     153               ! 
     154            ENDDO ! jk 
    152155            CALL iom_put( "runoffs", rnf )         ! output runoffs arrays 
    153156         ENDIF 
    … …  
    161164            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields red in the restart file' 
    162165            CALL iom_get( numror, jpdom_autoglo, 'rnf_b', rnf_b )     ! before runoff 
    163             CALL iom_get( numror, jpdom_autoglo, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) )   ! before heat content of runoff 
    164             CALL iom_get( numror, jpdom_autoglo, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) )   ! before salinity content of runoff 
     166            CALL iom_get( numror, jpdom_autoglo, 'rnf_hc_b', rnf_tsc_b(:,:,:,jp_tem) )   ! before heat content of runoff 
     167            CALL iom_get( numror, jpdom_autoglo, 'rnf_sc_b', rnf_tsc_b(:,:,:,jp_sal) )   ! before salinity content of runoff 
    165168         ELSE                                                   !* no restart: set from nit000 values 
    166169            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    167170             rnf_b    (:,:  ) = rnf    (:,:  )   
    168              rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)    
     171             rnf_tsc_b(:,:,:,:) = rnf_tsc(:,:,:,:)    
    169172         ENDIF 
    170173      ENDIF 
    … …  
    177180         IF(lwp) WRITE(numout,*) '~~~~' 
    178181         CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 
    179          CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 
    180          CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 
     182         CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,:,jp_tem) ) 
     183         CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,:,jp_sal) ) 
    181184      ENDIF 
    182185      ! 
    … …  
    377380      ! 
    378381      rnf(:,:) =  0._wp                         ! runoff initialisation 
    379       rnf_tsc(:,:,:) = 0._wp                    ! runoffs temperature & salinty contents initilisation 
     382      rnf_tsc(:,:,:,:) = 0._wp                    ! runoffs temperature & salinty contents initilisation 
    380383      ! 
    381384      !                                   ! ======================== 
    … …  
    457460      CALL iom_close( inum )                                      ! close file 
    458461       
    459       IF( nclosea == 1 )    CALL clo_rnf( rnfmsk )                ! closed sea inflow set as ruver mouth 
    460  
    461       rnfmsk_z(:)   = 0._wp                                        ! vertical structure  
     462      IF( nn_closea == 1 )   CALL clo_rnf( rnfmsk )               ! closed sea inflow set as ruver mouth 
     463 
     464      rnfmsk_z(:)   = 0._wp                                       ! vertical structure  
    462465      rnfmsk_z(1)   = 1.0 
    463466      rnfmsk_z(2)   = 1.0                                         ! ********** 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90

    r7363 r7367  
    7575      INTEGER  ::   ierror   ! return error code 
    7676      !! 
     77      REAL(wp) ::   sst1,sst2                      ! sea surface temperature   
     78      REAL(wp) ::   e_sst1, e_sst2                 ! saturation vapour pressure  
     79      REAL(wp) ::   qs1,qs2                        ! specific humidity  
     80      REAL(wp) ::   pr_tmp                         ! temporary variable for pressure  
     81  
     82      REAL(wp), DIMENSION(jpi,jpj) ::  hny_frc1    ! Haney forcing for sensible heat, correction for latent heat    
     83      REAL(wp), DIMENSION(jpi,jpj) ::  hny_frc2    ! Haney forcing for sensible heat, correction for latent heat    
     84  
     85      LOGICAL  ::   ln_UKMO_haney = .FALSE.        ! UKMO specific flag to calculate Haney forcing    
     86      !! 
    7787      CHARACTER(len=100) ::  cn_dir          ! Root directory for location of ssr files 
    7888      TYPE(FLD_N) ::   sn_sst, sn_sss        ! informations about the fields to be read 
    79       NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd 
     89      NAMELIST/namsbc_ssr/ cn_dir, nn_sstr, nn_sssr, rn_dqdt, rn_deds, sn_sst, sn_sss, ln_sssr_bnd, rn_sssr_bnd, ln_UKMO_haney 
    8090      !!---------------------------------------------------------------------- 
    8191      ! 
    … …  
    158168            IF( nn_sstr == 1 ) THEN                   !* Temperature restoring term 
    159169!CDIR COLLAPSE 
    160                DO jj = 1, jpj 
    161                   DO ji = 1, jpi 
    162                      zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) 
    163                      qns(ji,jj) = qns(ji,jj) + zqrp 
    164                      qrp(ji,jj) = zqrp 
     170               IF( ln_UKMO_haney ) THEN  
     171                  DO jj = 1, jpj 
     172                     DO ji = 1, jpi 
     173                        sst1   =  sst_m(ji,jj)  
     174                        sst2   =  sf_sst(1)%fnow(ji,jj,1)    
     175                        e_sst1 = 10**((0.7859+0.03477*sst1)/(1.+0.00412*sst1))   
     176                        e_sst2 = 10**((0.7859+0.03477*sst2)/(1.+0.00412*sst2))          
     177                        pr_tmp = 0.01*pressnow(ji,jj)  !pr_tmp = 1012.0  
     178                        qs1    = (0.62197*e_sst1)/(pr_tmp-0.378*e_sst1)  
     179                        qs2    = (0.62197*e_sst2)/(pr_tmp-0.378*e_sst2)  
     180                        hny_frc1(ji,jj) = sst1-sst2                     
     181                        hny_frc2(ji,jj) = qs1-qs2                      
     182                       !Might need to mask off land points.  
     183                        hny_frc1(ji,jj)=-hny_frc1(ji,jj)*wndm(ji,jj)*1.42  
     184                        hny_frc2(ji,jj)=-hny_frc2(ji,jj)*wndm(ji,jj)*4688.0  
     185                        qns(ji,jj)=qns(ji,jj)+hny_frc1(ji,jj)+hny_frc2(ji,jj)    
     186                        qrp(ji,jj) = 0.e0  
     187                     END DO  
     188                  END DO  
     189               ELSE  
     190                  DO jj = 1, jpj  
     191                     DO ji = 1, jpi  
     192                        zqrp = rn_dqdt * ( sst_m(ji,jj) - sf_sst(1)%fnow(ji,jj,1) ) 
     193                        qns(ji,jj) = qns(ji,jj) + zqrp 
     194                        qrp(ji,jj) = zqrp 
     195                     END DO 
    165196                  END DO 
    166                END DO 
     197               ENDIF 
    167198               CALL iom_put( "qrp", qrp )                             ! heat flux damping 
    168199            ENDIF 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r7363 r7367  
    7979# endif   
    8080      REAL(wp), POINTER, DIMENSION(:,:) :: zu_eiv, zv_eiv, zw_eiv, z2d 
     81      REAL(wp), POINTER, DIMENSION(:,:,:) :: uslp, vslp, wslpi, wslpj 
    8182      !!---------------------------------------------------------------------- 
    8283      ! 
    … …  
    8889      CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) 
    8990# endif 
     91      CALL wrk_alloc( jpi, jpj, jpk, uslp, vslp, wslpi, wslpj ) 
     92 
     93      IF ( ln_traldf_iso ) THEN   
     94         uslp  = uslp_iso   
     95         vslp  = vslp_iso   
     96         wslpi = wslpi_iso   
     97         wslpj = wslpj_iso   
     98      ELSEIF ( ln_traldf_hor ) THEN   
     99         uslp  = uslp_hor   
     100         vslp  = vslp_hor   
     101         wslpi = wslpi_hor   
     102         wslpj = wslpj_hor   
     103      ENDIF   
    90104 
    91105      IF( kt == kit000 )  THEN 
    … …  
    194208      CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) 
    195209# endif 
     210      CALL wrk_dealloc( jpi, jpj, jpk, uslp, vslp, wslpi, wslpj ) 
    196211      ! 
    197212      IF( nn_timing == 1 )  CALL timing_stop( 'tra_adv_eiv') 

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

    r7363 r7367  
    362362      REAL(wp) ::   zlat, zlat0, zlat1, zlat2   !   -      - 
    363363      REAL(wp) ::   zsdmp, zbdmp                !   -      - 
     364      REAL(wp) ::   zxpos1,zdistmax1,zxpos2,zypos2,zypos1,zdistmax2,zbuffer,zgdsup,zratio  
    364365      CHARACTER(len=20)                   :: cfile 
    365366      REAL(wp), POINTER, DIMENSION(:    ) :: zhfac  
    … …  
    441442         ! 
    442443      ENDIF 
    443  
     444      IF( cp_cfg /= "orca" .AND. ( nn_hdmp > 0 ) ) THEN  
     445         !  
     446         ! FOAM: Allow general Newtonian damping for regional models  
     447         ! Clunky arrangement of IF-ELSE tests here to avoid clash with ADTL branch.  
     448         ! NB. Mercator-Ocean implementation of damping near Gibraltar in "natl" model now implemented  
     449         ! in ADTL branch. Not used in FOAM V2.   
     450         !  
     451         !                                       ! ========================  
     452         IF(lwp) write(numout,*) 'No special Med Sea or Red Sea damping coefficients for '//cp_cfg//' model.'  
     453         !  
     454         ! Mask resto array and set to 0 first and last levels  
     455         resto(:,:, : ) = resto(:,:,:) * tmask(:,:,:)  
     456         resto(:,:, 1 ) = 0.e0  
     457         resto(:,:,jpk) = 0.e0  
     458         !  
     459         IF( cp_cfg == "natl" .AND. ( nn_hdmp > 0 .OR. nn_hdmp == -1 ) ) THEN  
     460  
     461!!! MERCATOR CODE START !!!  
     462!    ---------------------------------  
     463!     Med and Red Sea Straits damping (buffer zone)  
     464!    ---------------------------------  
     465!     Allowing a better vertical position of the dense water mass   
     466!     after a straits (Mediterranean water in the Atlantic, Red   
     467!     Sea water below the Bab el Manded straits, ...).  
     468!     The trend is computed from the depth tcrit down to the bottom.  
     469!     geographically the damping occurs in a circle of diameter  
     470!     sqrt(zdistmax) (in degrees) centered on (zxpos, zypos) (in degrees)  
     471!  
     472           IF(lwp)WRITE(numout,*)  
     473           IF(lwp)WRITE(numout,*) ' ***** : Buffer zone '  
     474           IF(lwp)WRITE(numout,*) '         in Gibraltar strait'  
     475           IF(lwp)WRITE(numout,*)  
     476   
     477!  
     478!! set the parameters for the Cadiz damping area  
     479          zxpos1   = 352.5  
     480          zypos1   = 36.  
     481         zdistmax1= 4.    
     482!! restoring coefficient (horizontal shape)  
     483           zbdmp = 1./(rn_surf * rday)  
     484           DO jk = 2, jpkm1  
     485             DO jj = 1, jpj  
     486               DO ji = 1, jpi  
     487                 zbuffer = 9999.  
     488                 zbuffer = MIN( zbuffer, ( (glamt(ji,jj)-zxpos1)**2+(gphit(ji,jj)-zypos1)**2)/zdistmax1 )  
     489                 zbuffer = (1.-MIN(zbuffer,1.))  
     490! ... newtonian damping throughout the water column  
     491                 zgdsup = 300.                ! Rappel dans Cadix en dessous de 300m  
     492                 !! Note Mercator used hdmp in the denominator here but it was fixed to 300m in the namelist.  
     493                 !! Didn't seem to make sense to use hdmp for two separate depth scales.  
     494                 zratio = MIN(1.,MAX(0.,(fsdept(ji,jj,jk)-zgdsup)/zgdsup))  
     495                 resto(ji,jj,jk) = resto(ji,jj,jk) + zratio * zbdmp * zbuffer  
     496               END DO  
     497             END DO  
     498           END DO  
     499  
     500         ENDIF  
     501!!! MERCATOR CODE END !!!  
     502  
     503      ELSE 
    444504      !                                  ! ========================= 
    445505      !                                  !  Med and Red Sea damping    (ORCA configuration only) 
    … …  
    535595         CASE ( 025 )                               !  ORCA_R025 configuration  
    536596            !                                       ! ======================== 
    537             CALL ctl_stop( ' Not yet implemented in ORCA_R025' ) 
     597            IF(lwp) write(numout,*) 'No special Med Sea or Red Sea damping coefficients for ORCA025'  
    538598            ! 
    539599         END SELECT 
    … …  
    553613      ENDIF 
    554614 
     615      ENDIF 
    555616      !                            !--------------------------------! 
    556617      IF( kn_file == 1 ) THEN      !  save damping coef. in a file  ! 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r7363 r7367  
    181181      REAL(wp), POINTER, DIMENSION(:,:) ::  zftu, zdkt, zdk1t 
    182182      REAL(wp), POINTER, DIMENSION(:,:) ::  zftw, zdit, zdjt, zdj1t 
     183      REAL(wp), POINTER, DIMENSION(:,:,:) ::  uslp, vslp, wslpi, wslpj 
    183184      !!---------------------------------------------------------------------- 
    184185      ! 
    … …  
    187188      CALL wrk_alloc( jpi, jpj, zftu, zdkt, zdk1t )  
    188189      CALL wrk_alloc( jpi, jpk, zftw, zdit, zdjt, zdj1t )  
    189       ! 
     190      CALL wrk_alloc( jpi, jpj, jpk, uslp, vslp, wslpi, wslpj )  
     191      ! 
     192      !  
     193      IF ( ln_traldf_iso ) THEN   
     194         uslp  = uslp_iso   
     195         vslp  = vslp_iso   
     196         wslpi = wslpi_iso   
     197         wslpj = wslpj_iso   
     198      ELSEIF ( ln_traldf_hor ) THEN   
     199         uslp  = uslp_hor   
     200         vslp  = vslp_hor   
     201         wslpi = wslpi_hor   
     202         wslpj = wslpj_hor   
     203      ENDIF  
     204 
    190205      DO jn = 1, kjpt 
    191206         !                               ! ********** !   ! =============== 
    … …  
    340355      CALL wrk_dealloc( jpi, jpj, zftu, zdkt, zdk1t )  
    341356      CALL wrk_dealloc( jpi, jpk, zftw, zdit, zdjt, zdj1t )  
     357      CALL wrk_dealloc( jpi, jpj, jpk, uslp, vslp, wslpi, wslpj )  
    342358      ! 
    343359      IF( nn_timing == 1 )  CALL timing_stop('ldfght') 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r7363 r7367  
    3434   USE wrk_nemo        ! Memory Allocation 
    3535   USE timing          ! Timing 
     36#if defined key_bdy   
     37   USE bdy_oce   
     38#endif   
    3639 
    3740   IMPLICIT NONE 
    … …  
    112115      REAL(wp), POINTER, DIMENSION(:,:  ) ::  zdkt, zdk1t, z2d 
    113116      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdit, zdjt, ztfw  
     117      REAL(wp), POINTER, DIMENSION(:,:,:) ::  uslp, vslp, wslpi, wslpj 
     118 
     119      REAL(wp), DIMENSION(jpi,jpj)     ::   zfactor  ! multiplier for diffusion 
    114120      !!---------------------------------------------------------------------- 
    115121      ! 
    … …  
    117123      ! 
    118124      CALL wrk_alloc( jpi, jpj,      zdkt, zdk1t, z2d )  
    119       CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw  )  
    120       ! 
     125      CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, uslp, vslp, wslpi, wslpj )  
     126      ! 
     127      IF ( ln_traldf_iso ) THEN   
     128         uslp  = uslp_iso   
     129         vslp  = vslp_iso   
     130         wslpi = wslpi_iso   
     131         wslpj = wslpj_iso   
     132      ELSEIF ( ln_traldf_hor ) THEN   
     133         uslp  = uslp_hor   
     134         vslp  = vslp_hor   
     135         wslpi = wslpi_hor   
     136         wslpj = wslpj_hor   
     137      ENDIF 
    121138 
    122139      IF( kt == kit000 )  THEN 
    … …  
    126143      ENDIF 
    127144      ! 
     145#if defined key_bdy  
     146      zfactor(:,:) = sponge_factor(:,:)  
     147#else  
     148      zfactor(:,:) = 1.0  
     149#endif 
    128150      !                                                          ! =========== 
    129151      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    176198            DO jj = 1 , jpjm1 
    177199               DO ji = 1, fs_jpim1   ! vector opt. 
    178                   zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
    179                   zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
     200                  zabe1 = zfactor(ji,jj) * ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
     201                  zabe2 = zfactor(ji,jj) * ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
    180202                  ! 
    181203                  zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
    … …  
    296318      ! 
    297319      CALL wrk_dealloc( jpi, jpj,      zdkt, zdk1t, z2d )  
    298       CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw  )  
     320      CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, uslp, vslp, wslpi, wslpj )  
    299321      ! 
    300322      IF( nn_timing == 1 )  CALL timing_stop('tra_ldf_iso') 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90

    r7363 r7367  
    225225            DO jj = 2, jpjm1 
    226226               DO ji = fs_2, fs_jpim1  ! vector opt. 
    227                   zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2v(ji,jj) + & 
    228                        &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1u(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
     227                  zw3d(ji,jj,jk) = (psiy_eiv(ji,jj,jk) - psiy_eiv(ji,jj-1,jk))/e2t(ji,jj) + & 
     228                       &    (psix_eiv(ji,jj,jk) - psix_eiv(ji-1,jj,jk))/e1t(ji,jj) ! w_eiv = dpsiy/dy + dpsiy/dx 
    229229               END DO 
    230230            END DO 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r7363 r7367  
    5757 
    5858   REAL(wp) ::   rbcp   ! Brown & Campana parameters for semi-implicit hpg 
     59   INTEGER  ::   warn_1, warn_2   ! indicators for warning statement 
    5960 
    6061   !! * Substitutions 
    … …  
    9293      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    9394      !! 
    94       INTEGER  ::   jk, jn    ! dummy loop indices 
    95       REAL(wp) ::   zfact     ! local scalars 
     95      INTEGER  ::   ji,jj,jk, jn     ! dummy loop indices 
     96      REAL(wp) ::   zfact, zfreeze   ! local scalars 
    9697      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    9798      !!---------------------------------------------------------------------- 
    … …  
    146147         ENDIF 
    147148      ENDIF  
     149      !  
     150#if ( ! defined key_lim3 && ! defined key_lim2 && ! key_cice )   
     151      IF ( kt == nit000 ) warn_1=0   
     152      warn_2=0   
     153      DO jk = 1, jpkm1   
     154        DO jj = 1, jpj   
     155          DO ji = 1, jpi   
     156            IF ( tsa(ji,jj,jk,jp_tem) .lt. 0.0 ) THEN   
     157               ! calculate the freezing point   
     158               zfreeze = ( -0.0575_wp + 1.710523E-3 * Sqrt (Abs(tsn(ji,jj,jk,jp_sal)))   &   
     159                         - 2.154996E-4 * tsn(ji,jj,jk,jp_sal) ) * tsn(ji,jj,jk,jp_sal) - 7.53E-4 * ( 10.0_wp + fsdept(ji,jj,jk) )   
     160               IF ( tsn(ji,jj,jk,jp_tem) .lt. zfreeze ) THEN   
     161                  tsn(ji,jj,jk,jp_tem)=zfreeze   
     162                  warn_2=1   
     163               ENDIF   
     164            ENDIF   
     165          END DO   
     166        END DO   
     167      END DO   
     168      CALL mpp_max(warn_1)   
     169      CALL mpp_max(warn_2)   
     170      IF ( (warn_1 == 0) .and. (warn_2 /= 0) ) THEN   
     171        IF(lwp) THEN   
     172          CALL ctl_warn( ' Temperatures dropping below freezing point, ', &   
     173                    &    ' being forced to freezing point, no longer conservative' )   
     174        ENDIF   
     175        warn_1=1   
     176      ENDIF   
     177#endif   
    148178      ! 
    149179#if defined key_agrif 

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

    r7363 r7367  
    1919   USE phycst          ! physical constant 
    2020   USE traqsr          ! solar radiation penetration 
     21   USE tradwl          ! solar radiation penetration (downwell method) 
    2122   USE trdmod_oce      ! ocean trends  
    2223   USE trdtra          ! ocean trends 
    … …  
    130131 
    131132!!gm      IF( .NOT.ln_traqsr )   qsr(:,:) = 0.e0   ! no solar radiation penetration 
    132       IF( .NOT.ln_traqsr ) THEN     ! no solar radiation penetration 
    133          qns(:,:) = qns(:,:) + qsr(:,:)      ! total heat flux in qns 
    134          qsr(:,:) = 0.e0                     ! qsr set to zero 
     133      IF( .NOT.ln_traqsr .and. .NOT.ln_tradwl ) THEN   ! no solar radiation penetration  
     134         qns(:,:) = qns(:,:) + qsr(:,:)                ! total heat flux in qns 
     135         qsr(:,:) = 0.e0                               ! qsr set to zero 
    135136      ENDIF 
    136137 
    … …  
    217218                  DO jk = 1, nk_rnf(ji,jj) 
    218219                                        tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
    219                                           &               +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
     220                                          &               +  ( rnf_tsc_b(ji,jj,jk,jp_tem) + rnf_tsc(ji,jj,jk,jp_tem) ) * zdep 
    220221                     IF( ln_rnf_sal )   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
    221                                           &               +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
     222                                          &               +  ( rnf_tsc_b(ji,jj,jk,jp_sal) + rnf_tsc(ji,jj,jk,jp_sal) ) * zdep  
    222223                  END DO 
    223224               ENDIF 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r7363 r7367  
    8989      REAL(wp) ::  zrhs, ze3tb, ze3tn, ze3ta   ! local scalars 
    9090      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwi, zwt 
     91      REAL(wp), POINTER, DIMENSION(:,:,:) ::  uslp, vslp, wslpi, wslpj 
    9192      !!--------------------------------------------------------------------- 
    9293      ! 
    9394      IF( nn_timing == 1 )  CALL timing_start('tra_zdf_imp') 
    9495      ! 
    95       CALL wrk_alloc( jpi, jpj, jpk, zwi, zwt )  
    96       ! 
     96      CALL wrk_alloc( jpi, jpj, jpk, zwi, zwt, uslp, vslp, wslpi, wslpj ) 
     97      ! 
     98#if defined key_ldfslp  
     99      IF ( ln_traldf_iso ) THEN   
     100         uslp  = uslp_iso   
     101         vslp  = vslp_iso   
     102         wslpi = wslpi_iso   
     103         wslpj = wslpj_iso   
     104      ELSEIF ( ln_traldf_hor ) THEN   
     105         uslp  = uslp_hor   
     106         vslp  = vslp_hor   
     107         wslpi = wslpi_hor   
     108         wslpj = wslpj_hor   
     109      ENDIF   
     110#endif  
     111 
    97112      IF( kt == kit000 )  THEN 
    98113         IF(lwp)WRITE(numout,*) 
    … …  
    230245      !                                               ! ================= ! 
    231246      ! 
    232       CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwt )  
     247      CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwt, uslp, vslp, wslpi, wslpj )  
    233248      ! 
    234249      IF( nn_timing == 1 )  CALL timing_stop('tra_zdf_imp') 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90

    r7363 r7367  
    88   !!            3.3  !  2010-06  (C. Ethe) merge TRA-TRC  
    99   !!---------------------------------------------------------------------- 
    10 #if  defined key_trdtra || defined key_trdmld || defined key_trdmld_trc  
     10#if  defined key_trdtra || defined key_trdtrc || defined key_trdmld || defined key_trdmld_trc  
    1111   !!---------------------------------------------------------------------- 
    1212   !!   trd_tra      : Call the trend to be computed 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90

    r7363 r7367  
    88   !!            3.2  ! 2009-09  (A.C.Coward)  Correction to include barotropic contribution 
    99   !!            3.3  ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase 
     10   !!            3.4  ! 2011-11  (H. Liu) implementation of semi-implicit bottom friction option 
     11   !!                 ! 2012-06  (H. Liu) implementation of Log Layer bottom friction option 
    1012   !!---------------------------------------------------------------------- 
    1113 
    … …  
    3032   PUBLIC   zdf_bfr_init    ! called by opa.F90 
    3133 
     34   REAL(wp), PARAMETER :: karman = 0.41_wp ! von Karman constant   
    3235   !                                    !!* Namelist nambfr: bottom friction namelist * 
    33    INTEGER  ::   nn_bfr    = 0           ! = 0/1/2/3 type of bottom friction  
    34    REAL(wp) ::   rn_bfri1  = 4.0e-4_wp   ! bottom drag coefficient (linear case)  
    35    REAL(wp) ::   rn_bfri2  = 1.0e-3_wp   ! bottom drag coefficient (non linear case) 
    36    REAL(wp) ::   rn_bfeb2  = 2.5e-3_wp   ! background bottom turbulent kinetic energy  [m2/s2] 
    37    REAL(wp) ::   rn_bfrien = 30._wp      ! local factor to enhance coefficient bfri 
    38    LOGICAL  ::   ln_bfr2d  = .false.     ! logical switch for 2D enhancement 
    39    LOGICAL , PUBLIC                            ::  ln_bfrimp = .false.  ! logical switch for implicit bottom friction 
     36   INTEGER  ::   nn_bfr      = 0           ! = 0/1/2/3 type of bottom friction  
     37   REAL(wp) ::   rn_bfri1    = 4.0e-4_wp   ! bottom drag coefficient (linear case)  
     38   REAL(wp) ::   rn_bfri2    = 1.0e-3_wp   ! bottom drag coefficient (non linear case) 
     39   REAL(wp) ::   rn_bfeb2    = 2.5e-3_wp   ! background bottom turbulent kinetic energy  [m2/s2] 
     40   REAL(wp) ::   rn_bfrien   = 30._wp      ! local factor to enhance coefficient bfri 
     41   REAL(wp) ::   rn_bfrz0    = 0.003_wp    ! bottom roughness for loglayer bfr coeff 
     42   LOGICAL  ::   ln_bfr2d    = .false.     ! logical switch for 2D enhancement 
     43   LOGICAL  ::   ln_loglayer = .false.     ! switch for log layer bfr coeff. 
     44   LOGICAL , PUBLIC                            ::  ln_bfrimp   = .false.  ! switch for implicit bottom friction 
    4045   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  bfrcoef2d            ! 2D bottom drag coefficient 
    4146 
    … …  
    8287      INTEGER  ::   ikbu, ikbv   ! local integers 
    8388      REAL(wp) ::   zvu, zuv, zecu, zecv   ! temporary scalars 
     89      REAL(wp) ::   ztmp         ! temporary scalars 
    8490      !!---------------------------------------------------------------------- 
    8591      ! 
    … …  
    9298         ! where -F_h/e3U_bot = bfrUa*Ub/e3U_bot {U=[u,v]} 
    9399         ! 
     100 
     101         IF(ln_loglayer) THEN       ! "log layer" bottom friction coefficient 
     102#  if defined key_vectopt_loop 
     103           DO jj = 1, 1 
     104             DO ji = 1, jpij   ! vector opt. (forced unrolling) 
     105#  else 
     106           DO jj = 1, jpj 
     107             DO ji = 1, jpi 
     108#  endif 
     109                ztmp = 0.5_wp * fse3t(ji,jj,mbkt(ji,jj)) 
     110                ztmp = max(ztmp, rn_bfrz0) 
     111                bfrcoef2d(ji,jj) = ( log( ztmp / rn_bfrz0 ) / karman ) ** (-2) 
     112             END DO 
     113           END DO 
     114         ENDIF 
     115 
    94116# if defined key_vectopt_loop 
    95117         DO jj = 1, 1 
    … …  
    117139            END DO 
    118140         END DO 
     141 
     142 
    119143         ! 
    120144         CALL lbc_lnk( bfrua, 'U', 1. )   ;   CALL lbc_lnk( bfrva, 'V', 1. )      ! Lateral boundary condition 
    … …  
    141165      USE iom   ! I/O module for ehanced bottom friction file 
    142166      !! 
    143       INTEGER ::   inum         ! logical unit for enhanced bottom friction file 
    144       INTEGER ::   ji, jj       ! dummy loop indexes 
    145       INTEGER ::   ikbu, ikbv   ! temporary integers 
    146       INTEGER ::   ictu, ictv   !    -          - 
    147       REAL(wp) ::  zminbfr, zmaxbfr   ! temporary scalars 
    148       REAL(wp) ::  zfru, zfrv         !    -         - 
    149       !! 
    150       NAMELIST/nambfr/ nn_bfr, rn_bfri1, rn_bfri2, rn_bfeb2, ln_bfr2d, rn_bfrien, ln_bfrimp 
     167      INTEGER   ::   inum         ! logical unit for enhanced bottom friction file 
     168      INTEGER   ::   ji, jj       ! dummy loop indexes 
     169      INTEGER   ::   ikbu, ikbv   ! temporary integers 
     170      INTEGER   ::   ictu, ictv   !    -          - 
     171      REAL(wp)  ::   zminbfr, zmaxbfr   ! temporary scalars 
     172      REAL(wp)  ::   zfru, zfrv         !    -         - 
     173      !! 
     174      NAMELIST/nambfr/ nn_bfr, rn_bfri1, rn_bfri2, rn_bfeb2, rn_bfrz0, ln_bfr2d, & 
     175                    &  rn_bfrien, ln_bfrimp, ln_loglayer 
    151176      !!---------------------------------------------------------------------- 
    152177      ! 
    … …  
    212237         ENDIF 
    213238         bfrcoef2d(:,:) = rn_bfri2  ! initialize bfrcoef2d to the namelist variable 
     239 
    214240         ! 
    215241         IF(ln_bfr2d) THEN  

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r7363 r7367  
    227227      ENDIF 
    228228      ! 
    229       !                              ! allocate zdfddm arrays 
     229      !                               ! allocate zdfddm arrays 
    230230      IF( zdf_ddm_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_ddm_init : unable to allocate arrays' ) 
     231      !                               ! initialization to masked Kz 
     232      avs(:,:,:) = rn_avt0 * tmask(:,:,:)  
    231233      ! 
    232234   END SUBROUTINE zdf_ddm_init 

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

    r7363 r7367  
    1515   USE prtctl          ! Print control 
    1616   USE iom             ! I/O library 
     17   USE eosbn2          ! Equation of state  
     18   USE phycst, ONLY : rau0 ! reference density  
     19   USE lbclnk  
    1720   USE lib_mpp         ! MPP library 
    1821   USE wrk_nemo        ! work arrays 
    … …  
    2427 
    2528   PUBLIC   zdf_mxl       ! called by step.F90 
    26  
     29    
     30   ! Namelist variables for  namzdf_karaml  
     31  
     32   LOGICAL   :: ln_kara            ! Logical switch for calculating kara mixed 
     33                                     ! layer 
     34   LOGICAL   :: ln_kara_write25h   ! Logical switch for 25 hour outputs 
     35   INTEGER   :: jpmld_type         ! mixed layer type              
     36   REAL(wp)  :: ppz_ref            ! depth of initial T_ref  
     37   REAL(wp)  :: ppdT_crit          ! Critical temp diff   
     38   REAL(wp)  :: ppiso_frac         ! Fraction of ppdT_crit used  
     39    
     40   !Used for 25h mean 
     41   LOGICAL, PRIVATE :: kara_25h_init = .TRUE.   !Logical used to initalise 25h  
     42                                                !outputs. Necissary, because we need to 
     43                                                !initalise the kara_25h on the zeroth 
     44                                                !timestep (i.e in the nemogcm_init call) 
     45   REAL, PRIVATE, ALLOCATABLE, DIMENSION(:,:) :: hmld_kara_25h 
     46    
    2747   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by TOP) 
     48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmld_kara  !: mixed layer depth of Kara et al   [m] 
    2849   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmld    !: mixing layer depth (turbocline)      [m] 
    2950   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlp    !: mixed layer depth  (rho=rho0+zdcrit) [m] 
    3051   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: mixed layer depth at t-points        [m] 
    31  
     52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmld_tref  !: mixed layer depth at t-points - temperature criterion [m] 
     53    
    3254   !! * Substitutions 
    3355#  include "domzgr_substitute.h90" 
    … …  
    4567      zdf_mxl_alloc = 0      ! set to zero if no array to be allocated 
    4668      IF( .NOT. ALLOCATED( nmln ) ) THEN 
    47          ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), STAT= zdf_mxl_alloc ) 
     69         ALLOCATE( nmln(jpi,jpj), hmld(jpi,jpj), hmlp(jpi,jpj), hmlpt(jpi,jpj), &  
     70                                            hmld_tref(jpi,jpj), STAT= zdf_mxl_alloc )  
    4871         ! 
    4972         IF( lk_mpp             )   CALL mpp_sum ( zdf_mxl_alloc ) 
    … …  
    5982      !!                    
    6083      !! ** Purpose :   Compute the turbocline depth and the mixed layer depth 
    61       !!              with density criteria. 
     84      !!      with a simple density criteria. Also calculates the mixed layer  
     85      !!      depth of Kara et al by calling zdf_mxl_kara.  
    6286      !! 
    6387      !! ** Method  :   The mixed layer depth is the shallowest W depth with  
    … …  
    78102      REAL(wp) ::   zrho_c = 0.01_wp    ! density criterion for mixed layer depth 
    79103      REAL(wp) ::   zavt_c = 5.e-4_wp   ! Kz criterion for the turbocline depth 
     104      REAL(wp) ::   t_ref               ! Reference temperature   
     105      REAL(wp) ::   temp_c = 0.2        ! temperature criterion for mixed layer depth   
    80106      !!---------------------------------------------------------------------- 
    81107      ! 
    … …  
    104130      END DO 
    105131      ! depth of the mixing and mixed layers 
     132       
     133      CALL zdf_mxl_kara( kt )  
     134       
    106135      DO jj = 1, jpj 
    107136         DO ji = 1, jpi 
    … …  
    113142         END DO 
    114143      END DO 
     144#if defined key_iomput  
    115145      IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    116146         CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
    117147         CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
    118148      ENDIF 
    119        
     149#endif 
     150 
     151      !For the AMM model assimiation uses a temperature based mixed layer depth   
     152      !This is defined here   
     153      DO jj = 1, jpj   
     154         DO ji = 1, jpi   
     155           hmld_tref(ji,jj)=fsdept(ji,jj,1  )    
     156           IF(tmask(ji,jj,1) > 0.)THEN   
     157             t_ref=tsn(ji,jj,1,jp_tem)  
     158             DO jk=2,jpk   
     159               IF(tmask(ji,jj,jk)==0.)THEN   
     160                  hmld_tref(ji,jj)=fsdept(ji,jj,jk )   
     161                  EXIT   
     162               ELSEIF( ABS(tsn(ji,jj,jk,jp_tem)-t_ref) < temp_c)THEN   
     163                  hmld_tref(ji,jj)=fsdept(ji,jj,jk )   
     164               ELSE   
     165                  EXIT   
     166               ENDIF   
     167             ENDDO   
     168           ENDIF   
     169         ENDDO   
     170      ENDDO 
     171             
    120172      IF(ln_ctl)   CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ', ovlap=1 ) 
    121173      ! 
    … …  
    125177      ! 
    126178   END SUBROUTINE zdf_mxl 
    127  
     179    
     180    
     181   SUBROUTINE zdf_mxl_kara( kt )  
     182      !!----------------------------------------------------------------------------------  
     183      !!                    ***  ROUTINE zdf_mxl_kara  ***  
     184      !                                                                         
     185      !   Calculate mixed layer depth according to the definition of           
     186      !   Kara et al, 2000, JGR, 105, 16803.   
     187      !  
     188      !   If mld_type=1 the mixed layer depth is calculated as the depth at which the   
     189      !   density has increased by an amount equivalent to a temperature difference of   
     190      !   0.8C at the surface.  
     191      !  
     192      !   For other values of mld_type the mixed layer is calculated as the depth at   
     193      !   which the temperature differs by 0.8C from the surface temperature.   
     194      !                                                                         
     195      !   Original version: David Acreman                                       
     196      !  
     197      !!----------------------------------------------------------------------------------- 
     198      
     199      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index  
     200  
     201      NAMELIST/namzdf_karaml/ ln_kara,jpmld_type, ppz_ref, ppdT_crit, & 
     202      &                       ppiso_frac, ln_kara_write25h  
     203  
     204      ! Local variables                                                         
     205      REAL, DIMENSION(jpi,jpk) :: ppzdep      ! depth for use in calculating d(rho)  
     206      REAL(wp), DIMENSION(jpi,jpj,jpts) :: ztsn_2d  !Local version of tsn  
     207      LOGICAL :: ll_found(jpi,jpj)              ! Is T_b to be found by interpolation ?  
     208      LOGICAL :: ll_belowml(jpi,jpj,jpk)        ! Flag points below mixed layer when ll_found=F  
     209      INTEGER :: ji, jj, jk                     ! loop counter  
     210      INTEGER :: ik_ref(jpi,jpj)                ! index of reference level  
     211      INTEGER :: ik_iso(jpi,jpj)                ! index of last uniform temp level  
     212      REAL    :: zT(jpi,jpj,jpk)                ! Temperature or denisty  
     213      REAL    :: zT_ref(jpi,jpj)                ! reference temperature  
     214      REAL    :: zT_b                           ! base temperature  
     215      REAL    :: zdTdz(jpi,jpj,jpk-2)           ! gradient of zT  
     216      REAL    :: zmoddT(jpi,jpj,jpk-2)          ! Absolute temperature difference  
     217      REAL    :: zdz                            ! depth difference  
     218      REAL    :: zdT                            ! temperature difference  
     219      REAL    :: zdelta_T(jpi,jpj)              ! difference critereon  
     220      REAL    :: zRHO1(jpi,jpj), zRHO2(jpi,jpj) ! Densities 
     221      INTEGER, SAVE :: idt, i_steps 
     222      INTEGER, SAVE :: i_cnt_25h     ! Counter for 25 hour means 
     223      
     224  
     225      !!-------------------------------------------------------------------------------------  
     226  
     227      IF( kt == nit000 ) THEN  
     228         ! Default values  
     229         ln_kara      = .FALSE. 
     230         ln_kara_write25h = .FALSE.  
     231         jpmld_type   = 1      
     232         ppz_ref      = 10.0  
     233         ppdT_crit    = 0.2   
     234         ppiso_frac   = 0.1    
     235         ! Read namelist  
     236         REWIND ( numnam )     
     237         READ   ( numnam, namzdf_karaml )  
     238         WRITE(numout,*) '===== Kara mixed layer ====='  
     239         WRITE(numout,*) 'ln_kara = ',    ln_kara 
     240         WRITE(numout,*) 'jpmld_type = ', jpmld_type  
     241         WRITE(numout,*) 'ppz_ref = ',    ppz_ref  
     242         WRITE(numout,*) 'ppdT_crit = ',  ppdT_crit  
     243         WRITE(numout,*) 'ppiso_frac = ', ppiso_frac 
     244         WRITE(numout,*) 'ln_kara_write25h = ', ln_kara_write25h 
     245         WRITE(numout,*) '============================'  
     246       
     247         IF ( .NOT.ln_kara ) THEN 
     248            WRITE(numout,*) "ln_kara not set; Kara mixed layer not calculated"  
     249         ELSE 
     250            IF (.NOT. ALLOCATED(hmld_kara) ) ALLOCATE( hmld_kara(jpi,jpj) ) 
     251            IF ( ln_kara_write25h .AND. kara_25h_init ) THEN 
     252               i_cnt_25h = 0 
     253               IF (.NOT. ALLOCATED(hmld_kara_25h) ) & 
     254               &   ALLOCATE( hmld_kara_25h(jpi,jpj) ) 
     255               hmld_kara_25h = 0._wp 
     256               IF( nacc == 1 ) THEN 
     257                  idt = INT(rdtmin) 
     258               ELSE 
     259                  idt = INT(rdt) 
     260               ENDIF 
     261               IF( MOD( 3600,idt) == 0 ) THEN  
     262                  i_steps = 3600 / idt   
     263               ELSE  
     264                  CALL ctl_stop('STOP', & 
     265                  & 'zdf_mxl_kara: timestep must give MOD(3600,rdt)'// & 
     266                  & ' = 0 otherwise no hourly values are possible')  
     267               ENDIF   
     268            ENDIF 
     269         ENDIF 
     270      ENDIF 
     271       
     272      IF ( ln_kara ) THEN 
     273          
     274         !set critical ln_kara 
     275         ztsn_2d = tsn(:,:,1,:) 
     276         ztsn_2d(:,:,jp_tem) = ztsn_2d(:,:,jp_tem) + ppdT_crit 
     277      
     278         ! Set the mixed layer depth criterion at each grid point  
     279         ppzdep = 0._wp 
     280         IF( jpmld_type == 1 ) THEN                                          
     281            CALL eos ( tsn(:,:,1,:), & 
     282            &          ppzdep(:,:), zRHO1(:,:) )  
     283            CALL eos ( ztsn_2d(:,:,:), & 
     284            &           ppzdep(:,:), zRHO2(:,:) )  
     285            zdelta_T(:,:) = abs( zRHO1(:,:) - zRHO2(:,:) ) * rau0  
     286            ! RHO from eos (2d version) doesn't calculate north or east halo:  
     287            CALL lbc_lnk( zdelta_T, 'T', 1. )  
     288            zT(:,:,:) = rhop(:,:,:)  
     289         ELSE  
     290            zdelta_T(:,:) = ppdT_crit                       
     291            zT(:,:,:) = tsn(:,:,:,jp_tem)                            
     292         ENDIF  
     293      
     294         ! Calculate the gradient of zT and absolute difference for use later  
     295         DO jk = 1 ,jpk-2  
     296            zdTdz(:,:,jk)  =    ( zT(:,:,jk+1) - zT(:,:,jk) ) / fse3w(:,:,jk+1)  
     297            zmoddT(:,:,jk) = abs( zT(:,:,jk+1) - zT(:,:,jk) )  
     298         END DO  
     299      
     300         ! Find density/temperature at the reference level (Kara et al use 10m).           
     301         ! ik_ref is the index of the box centre immediately above or at the reference level  
     302         ! Find ppz_ref in the array of model level depths and find the ref     
     303         ! density/temperature by linear interpolation.                                    
     304         ik_ref = -1 
     305         DO jk = jpkm1, 2, -1  
     306            WHERE( fsdept(:,:,jk) > ppz_ref )  
     307               ik_ref(:,:) = jk - 1  
     308               zT_ref(:,:) = zT(:,:,jk-1) + & 
     309               &             zdTdz(:,:,jk-1) * ( ppz_ref - fsdept(:,:,jk-1) )  
     310            ENDWHERE  
     311         END DO 
     312         IF ( ANY( ik_ref  < 0 ) .OR. ANY( ik_ref  > jpkm1 ) ) THEN 
     313            CALL ctl_stop( "STOP", & 
     314            & "zdf_mxl_kara: unable to find reference level for kara ML" )  
     315         ELSE 
     316            ! If the first grid box centre is below the reference level then use the  
     317            ! top model level to get zT_ref  
     318            WHERE( fsdept(:,:,1) > ppz_ref )   
     319               zT_ref = zT(:,:,1)  
     320               ik_ref = 1  
     321            ENDWHERE  
     322      
     323            ! Search for a uniform density/temperature region where adjacent levels           
     324            ! differ by less than ppiso_frac * deltaT.                                       
     325            ! ik_iso is the index of the last level in the uniform layer   
     326            ! ll_found indicates whether the mixed layer depth can be found by interpolation  
     327            ik_iso(:,:)   = ik_ref(:,:)  
     328            ll_found(:,:) = .false.  
     329            DO jj = 1, nlcj  
     330               DO ji = 1, nlci  
     331                 !CDIR NOVECTOR  
     332                  DO jk = ik_ref(ji,jj), mbathy(ji,jj)-1  
     333                     IF( zmoddT(ji,jj,jk) > ( ppiso_frac * zdelta_T(ji,jj) ) ) THEN  
     334                        ik_iso(ji,jj)   = jk  
     335                        ll_found(ji,jj) = ( zmoddT(ji,jj,jk) > zdelta_T(ji,jj) )  
     336                        EXIT  
     337                     ENDIF  
     338                  END DO  
     339               END DO  
     340            END DO  
     341      
     342            ! Use linear interpolation to find depth of mixed layer base where possible  
     343            hmld_kara(:,:) = ppz_ref  
     344            DO jj = 1, jpj  
     345               DO ji = 1, jpi  
     346                  IF( ll_found(ji,jj) .and. tmask(ji,jj,1) == 1.0 ) THEN  
     347                     zdz =  abs( zdelta_T(ji,jj) / zdTdz(ji,jj,ik_iso(ji,jj)) )  
     348                     hmld_kara(ji,jj) = fsdept(ji,jj,ik_iso(ji,jj)) + zdz  
     349                  ENDIF  
     350               END DO  
     351            END DO  
     352      
     353            ! If ll_found = .false. then calculate MLD using difference of zdelta_T     
     354            ! from the reference density/temperature  
     355      
     356            ! Prevent this section from working on land points  
     357            WHERE( tmask(:,:,1) /= 1.0 )  
     358               ll_found = .true.  
     359            ENDWHERE  
     360      
     361            DO jk = 1, jpk  
     362               ll_belowml(:,:,jk) = abs( zT(:,:,jk) - zT_ref(:,:) ) >= & 
     363               & zdelta_T(:,:) 
     364            END DO  
     365      
     366            ! Set default value where interpolation cannot be used (ll_found=false)   
     367            DO jj = 1, jpj  
     368               DO ji = 1, jpi  
     369                  IF( .NOT. ll_found(ji,jj) )  & 
     370                  &   hmld_kara(ji,jj) = fsdept(ji,jj,mbathy(ji,jj))  
     371               END DO  
     372            END DO  
     373      
     374            DO jj = 1, jpj  
     375               DO ji = 1, jpi  
     376                  !CDIR NOVECTOR  
     377                  DO jk = ik_ref(ji,jj)+1, mbathy(ji,jj)  
     378                     IF( ll_found(ji,jj) ) EXIT  
     379                     IF( ll_belowml(ji,jj,jk) ) THEN                 
     380                        zT_b = zT_ref(ji,jj) + zdelta_T(ji,jj) * & 
     381                        &      SIGN(1.0, zdTdz(ji,jj,jk-1) )  
     382                        zdT  = zT_b - zT(ji,jj,jk-1)                                       
     383                        zdz  = zdT / zdTdz(ji,jj,jk-1)                                        
     384                        hmld_kara(ji,jj) = fsdept(ji,jj,jk-1) + zdz  
     385                        EXIT                                                    
     386                     ENDIF  
     387                  END DO  
     388               END DO  
     389            END DO  
     390      
     391            hmld_kara(:,:) = hmld_kara(:,:) * tmask(:,:,1)  
     392  
     393            IF(  ln_kara_write25h  ) THEN 
     394               !Double IF required as i_steps not defined if ln_kara_write25h = 
     395               ! FALSE 
     396               IF ( ( MOD( kt, i_steps ) == 0 ) .OR.  kara_25h_init ) THEN 
     397                  hmld_kara_25h = hmld_kara_25h + hmld_kara 
     398                  i_cnt_25h = i_cnt_25h + 1 
     399                  IF ( kara_25h_init ) kara_25h_init = .FALSE. 
     400               ENDIF 
     401            ENDIF 
     402  
     403#if defined key_iomput  
     404            IF( kt /= nit000 ) THEN  
     405               CALL iom_put( "mldkara"  , hmld_kara )    
     406               IF( ( MOD( i_cnt_25h, 25) == 0 ) .AND.  ln_kara_write25h ) & 
     407                  CALL iom_put( "kara25h"  , ( hmld_kara_25h / 25._wp ) ) 
     408            ENDIF 
     409#endif 
     410  
     411         ENDIF 
     412      ENDIF 
     413        
     414   END SUBROUTINE zdf_mxl_kara  
     415    
    128416   !!====================================================================== 
    129417END MODULE zdfmxl 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r7363 r7367  
    8787   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    8888   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
     89   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     90   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    8991#if defined key_c1d 
    9092   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    … …  
    112114         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    113115#endif 
    114          &      en   (jpi,jpj,jpk) , htau (jpi,jpj)     , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc ) 
     116         &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
     117         &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
     118         &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
    115119         ! 
    116120      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    … …  
    168172      !!---------------------------------------------------------------------- 
    169173      ! 
     174      IF( kt /= nit000 ) THEN   ! restore before value to compute tke 
     175         avt (:,:,:) = avt_k (:,:,:)  
     176         avm (:,:,:) = avm_k (:,:,:)  
     177         avmu(:,:,:) = avmu_k(:,:,:)  
     178         avmv(:,:,:) = avmv_k(:,:,:)  
     179      ENDIF  
     180      ! 
    170181      CALL tke_tke      ! now tke (en) 
    171182      ! 
    172183      CALL tke_avn      ! now avt, avm, avmu, avmv 
     184      ! 
     185      avt_k (:,:,:) = avt (:,:,:)  
     186      avm_k (:,:,:) = avm (:,:,:)  
     187      avmu_k(:,:,:) = avmu(:,:,:)  
     188      avmv_k(:,:,:) = avmv(:,:,:)  
    173189      ! 
    174190   END SUBROUTINE zdf_tke 
    … …  
    811827        !                                   ! ------------------- 
    812828        IF(lwp) WRITE(numout,*) '---- tke-rst ----' 
    813         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en    ) 
    814         CALL iom_rstput( kt, nitrst, numrow, 'avt'  , avt   ) 
    815         CALL iom_rstput( kt, nitrst, numrow, 'avm'  , avm   ) 
    816         CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu  ) 
    817         CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv  ) 
    818         CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) 
     829        CALL iom_rstput( kt, nitrst, numrow, 'en'   , en     ) 
     830        CALL iom_rstput( kt, nitrst, numrow, 'avt'  , avt_k  ) 
     831        CALL iom_rstput( kt, nitrst, numrow, 'avm'  , avm_k  ) 
     832        CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 
     833        CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv_k ) 
     834        CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl  ) 
    819835        ! 
    820836     ENDIF 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/lib_fortran.F90

    r7363 r7367  
    1414   !!                 of intrinsinc sign function 
    1515   !!---------------------------------------------------------------------- 
    16    USE par_oce          ! Ocean parameter 
    17    USE lib_mpp          ! distributed memory computing 
    18    USE dom_oce          ! ocean domain 
    19    USE in_out_manager   ! I/O manager 
     16   USE par_oce         ! Ocean parameter 
     17   USE dom_oce         ! ocean domain 
     18   USE in_out_manager  ! I/O manager 
     19   USE lib_mpp         ! distributed memory computing 
    2020 
    2121   IMPLICIT NONE 
    2222   PRIVATE 
    2323 
    24    PUBLIC glob_sum 
     24   PUBLIC   glob_sum   ! used in many places 
     25   PUBLIC   DDPDD      ! also used in closea module 
    2526#if defined key_nosignedzero 
    2627   PUBLIC SIGN 
    … …  
    4748 
    4849#if ! defined key_mpp_rep 
     50 
    4951   FUNCTION glob_sum_2d( ptab )  
    5052      !!----------------------------------------------------------------------- 
    … …  
    246248   END FUNCTION glob_sum_3d_a    
    247249 
     250#endif 
    248251 
    249252   SUBROUTINE DDPDD( ydda, yddb ) 
    … …  
    280283      ! 
    281284   END SUBROUTINE DDPDD 
    282 #endif 
    283285 
    284286#if defined key_nosignedzero 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/module_example

    r7363 r7367  
    5252   !!---------------------------------------------------------------------- 
    5353   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    54    !! $Id: module_example 2737 2011-04-11 10:30:51Z rblod $  
     54   !! $Id: module_example 2528 2010-12-27 17:33:53Z rblod $  
    5555   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5656   !!---------------------------------------------------------------------- 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r7363 r7367  
    1111   !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice  
    1212   !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,  
    13    !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0 
     13   !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialard, A.M. Treguier, M. Levy) release 8.0 
    1414   !!            8.1  ! 1997-06  (M. Imbard, G. Madec) 
    1515   !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  LIM sea-ice model  
    … …  
    5454   USE ldftra          ! lateral diffusivity setting    (ldftra_init routine) 
    5555   USE zdfini          ! vertical physics setting          (zdf_init routine) 
     56#if defined key_shelf   
     57   USE zdfmxl          ! mixed layer depth (needed for shelf SST assimilation)   
     58#endif      
    5659   USE phycst          ! physical constant                  (par_cst routine) 
    5760   USE trdmod          ! momentum/tracers trends       (trd_mod_init routine) 
    … …  
    6871   USE c1d             ! 1D configuration 
    6972   USE step_c1d        ! Time stepping loop for the 1D configuration 
     73   USE depwri          ! Depths writing 
    7074#if defined key_top 
    7175   USE trcini          ! passive tracer initialisation 
    … …  
    8185   PUBLIC   nemo_gcm    ! called by model.F90 
    8286   PUBLIC   nemo_init   ! needed by AGRIF 
    83  
     87   PUBLIC   nemo_alloc  
     88   PUBLIC   nemo_partition ! needed by NEMOVAR  
     89    
    8490   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing 
    8591 
    … …  
    132138      istp = nit000 
    133139#if defined key_c1d 
    134          DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    135             CALL stp_c1d( istp ) 
    136             istp = istp + 1 
    137          END DO 
     140      DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
     141         CALL stp_c1d( istp ) 
     142         istp = istp + 1 
     143      END DO 
    138144#else 
    139           IF( lk_asminc ) THEN 
    140              IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 )    ! Output background fields 
    141              IF( ln_trjwri ) CALL asm_trj_wri( nit000 - 1 )    ! Output trajectory fields 
    142              IF( ln_asmdin ) THEN                        ! Direct initialization 
    143                 IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 )    ! Tracers 
    144                 IF( ln_dyninc ) THEN  
    145                    CALL dyn_asm_inc( nit000 - 1 )    ! Dynamics 
    146                    IF ( ln_asmdin ) CALL ssh_wzv ( nit000 - 1 )      ! update vertical velocity  
    147                 ENDIF 
    148                 IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 )    ! SSH 
    149              ENDIF 
    150           ENDIF 
     145      IF( lk_asminc ) THEN  
     146         IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 )    ! Output background fields  
     147         IF( ln_trjwri ) CALL asm_trj_wri( nit000 - 1 )    ! Output trajectory fields  
     148         IF( ln_asmdin ) THEN                              ! Direct initialization  
     149            IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 )    ! Tracers  
     150            IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 )    ! Dynamics  
     151            IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 )    ! SSH  
     152         ENDIF  
     153      ENDIF  
    151154         
    152          DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
     155      DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    153156#if defined key_agrif 
    154157            CALL Agrif_Step( stp )           ! AGRIF: time stepping 
    … …  
    158161            istp = istp + 1 
    159162            IF( lk_mpp )   CALL mpp_max( nstop ) 
    160          END DO 
     163      END DO 
    161164#endif 
    162165 
    … …  
    187190      IF( lk_mpp )   CALL mppstop       ! end mpp communications 
    188191#endif 
     192      !  
     193      ! Met Office addition: if failed, return non-zero exit code  
     194      IF( nstop /= 0 )  CALL exit( 9 )  
    189195      ! 
    190196   END SUBROUTINE nemo_gcm 
    … …  
    308314                            CALL     dom_cfg    ! Domain configuration 
    309315                            CALL     dom_init   ! Domain 
     316      IF ( ln_depwri )      CALL dep_wri( nit000 ) ! write depths  
    310317 
    311318      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined) 
    … …  
    378385      ENDIF       
    379386      !                                     ! Assimilation increments 
    380       IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments 
     387      IF( lk_asminc ) THEN   
     388#if defined key_shelf   
     389         CALL zdf_mxl(1)        ! Initalise mixed layer depth for shelf assim         
     390#endif   
     391         CALL asm_inc_init     ! Initialize assimilation increments   
     392      ENDIF 
    381393      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 
    382       ! 
     394                            CALL dia_wri_tmb_init  ! TMB outputs 
     395      ! 
     396 
     397                            CALL dia_wri_tide_init ! 25 hour mean outputs 
     398 
    383399   END SUBROUTINE nemo_init 
    384400 
    … …  
    407423         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt 
    408424         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench 
     425         WRITE(numout,*) '      timing activated    (0/1)       nn_timing  = ', nn_timing 
    409426      ENDIF 
    410427      ! 
    … …  
    489506      IF( numout      /=  6 )   CLOSE( numout      )   ! standard model output file 
    490507      IF( numdct_vol  /= -1 )   CLOSE( numdct_vol  )   ! volume transports 
    491       IF( numdct_heat /= -1 )   CLOSE( numdct_heat )   ! heat transports 
    492       IF( numdct_salt /= -1 )   CLOSE( numdct_salt )   ! salt transports 
     508      IF( numdct_temp /= -1 )   CLOSE( numdct_temp )   ! heat transports 
     509      IF( numdct_sal  /= -1 )   CLOSE( numdct_sal  )   ! salt transports 
     510      IF( numdct_NOOS /= -1 )   CLOSE( numdct_NOOS )   ! NOOS transports 
    493511 
    494512      ! 
    … …  
    507525      !!---------------------------------------------------------------------- 
    508526      USE diawri    , ONLY: dia_wri_alloc 
     527      USE insitu_tem, ONLY: insitu_tem_alloc 
     528      USE bartrop_uv, ONLY: bartrop_uv_alloc 
     529#if ! defined key_iomput 
     530      USE diafoam   , ONLY: int_dia_wri_foam_alloc, real_dia_wri_foam_alloc 
     531#endif 
    509532      USE dom_oce   , ONLY: dom_oce_alloc 
    510533      USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc 
    511534      USE ldftra_oce, ONLY: ldftra_oce_alloc 
    512535      USE trc_oce   , ONLY: trc_oce_alloc 
     536#if defined key_diadct 
     537      USE diadct    , ONLY: diadct_alloc 
     538#endif 
    513539      ! 
    514540      INTEGER :: ierr 
    … …  
    517543      ierr =        oce_alloc       ()          ! ocean  
    518544      ierr = ierr + dia_wri_alloc   () 
     545      ierr = ierr + insitu_tem_alloc() 
     546      ierr = ierr + bartrop_uv_alloc() 
     547#if ! defined key_iomput 
     548      ierr = ierr + int_dia_wri_foam_alloc  ()   
     549      ierr = ierr + real_dia_wri_foam_alloc ()   
     550#endif 
    519551      ierr = ierr + dom_oce_alloc   ()          ! ocean domain 
    520552      ierr = ierr + ldfdyn_oce_alloc()          ! ocean lateral  physics : dynamics 
    … …  
    524556      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges 
    525557      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays 
     558      ! 
     559#if defined key_diadct 
     560      ierr = ierr + diadct_alloc    ()          ! 
     561#endif 
    526562      ! 
    527563      IF( lk_mpp    )   CALL mpp_sum( ierr ) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_EEL_R2.h90

    r7363 r7367  
    2424      jpidta  = 83,          &  !: 1st horizontal dimension ( >= jpi ) 
    2525      jpjdta  = 242,         &  !: 2nd    "            "    ( >= jpj ) 
     26#if key_levels == 1  
     27      jpkdta  = 2,           &  !: 1 level run  
     28#else  
    2629      jpkdta  = 30,          &  !: number of levels         ( >= jpk ) 
     30#endif 
    2731 
    2832      ! global domain size     !!! * full domain * 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_EEL_R5.h90

    r7363 r7367  
    2424      jpidta  =  66   ,      &  !: first horizontal dimension > or = to jpi 
    2525      jpjdta  =  66   ,      &  !: second                     > or = to jpj 
     26#if key_levels == 1  
     27      jpkdta  = 2,           &  !: 1 level run  
     28#else  
    2629      jpkdta  =  31   ,      &  !: number of levels           > or = to jpk 
     30#endif 
    2731 
    2832      ! total domain size      !!! * full domain * 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_EEL_R6.h90

    r7363 r7367  
    2424      jpidta  = 29,          &  !: 1st lateral dimension ( >= jpi ) 
    2525      jpjdta  = 83,          &  !: 2nd    "         "    ( >= jpj ) 
     26#if key_levels == 1  
     27      jpkdta  = 2,           &  !: 1 level run  
     28#else 
    2629      jpkdta  = 30,          &  !: number of levels      ( >= jpk ) 
     30#endif 
    2731 
    2832      ! global domain size     !!! * full domain * 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_GYRE.h90

    r7363 r7367  
    2424      jpidta  = 30*jp_cfg+2, &  !: 1st horizontal dimension ( >= jpi ) 
    2525      jpjdta  = 20*jp_cfg+2, &  !: 2nd    "            "    ( >= jpj ) 
     26#if key_levels == 1  
     27      jpkdta  = 2,           &  !: 1 level run  
     28#else  
    2629      jpkdta  = 31,          &  !: number of levels         ( >= jpk ) 
     30#endif 
    2731 
    2832      ! global domain size     !!! * full domain * 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_ORCA_R05.h90

    r7363 r7367  
    2525      jpidta  = 722,         &  !: 1st lateral dimension > or = to jpiglo 
    2626      jpjdta  = 511,         &  !: 2nd   "         "     > or = to jpjglo 
     27#if key_levels == 1  
     28      jpkdta  = 2,           &  !: 1 level run  
     29#else 
    2730      jpkdta  =  31             !: number of levels      > or = to jpkglo 
     31#endif  
    2832 
    2933#if defined key_antarctic 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_ORCA_R1.h90

    r7363 r7367  
    3030      jpkdta  = 75 ,         &  !: number of levels           > or = to jpk 
    3131#else 
    32       jpkdta  = 46 ,         &  !: number of levels           > or = to jpk 
     32      jpkdta  = 42 ,         &  !: number of levels           > or = to jpk 
    3333#endif 
    3434      ! total domain matrix size 
    … …  
    102102#else 
    103103   REAL(wp), PARAMETER  ::       & 
    104       &     ppsur = pp_to_be_computed ,        &  !: Computed in domzgr, set ppdzmin and pphmax below 
    105       &     ppa0  = pp_to_be_computed ,        &  !:    "           " 
    106       &     ppa1  = pp_to_be_computed ,        &  !:    "           " 
     104      &     ppsur = -3152.95254623653_wp ,     &  !: Computed in domzgr, set ppdzmin and pphmax below 
     105      &     ppa0  =   155.00000000000_wp ,     &  !:    "           " 
     106      &     ppa1  =   145.00000000000_wp ,     &  !:    "           " 
    107107      ! 
    108       &     ppkth =  23.563_wp        ,        &  !: (non dimensional): gives the approximate 
     108      &     ppkth =  25.48709749900_wp   ,     &  !: (non dimensional): gives the approximate 
    109109      !                                           !: layer number above which  stretching will 
    110110      !                                           !: be maximum. Usually of order jpk/2. 
    111       &     ppacr =   9.00000000000_wp            !: (non dimensional): stretching factor 
     111      &     ppacr =   5.50000000000_wp            !: (non dimensional): stretching factor 
    112112      !                                           !: for the grid. The highest zacr, the smallest 
    113113      !                                           !: the stretching. 
    … …  
    117117   !! 
    118118   REAL(wp), PARAMETER ::                      & 
    119       &     ppdzmin = 6._wp           ,        &  !: (meters) vertical thickness of the top layer 
    120       &     pphmax  = 5750._wp                    !: (meters) Maximum depth of the ocean gdepw(jpk) 
     119      &     ppdzmin = pp_not_used           ,  &  !: (meters) vertical thickness of the top layer 
     120      &     pphmax  = pp_not_used                 !: (meters) Maximum depth of the ocean gdepw(jpk) 
    121121   !! 
    122122   LOGICAL,  PARAMETER ::                      & 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_ORCA_R2.h90

    r7363 r7367  
    2525      jpidta  = 182,         &  !: 1st lateral dimension ( >= jpiglo ) 
    2626      jpjdta  = 149,         &  !: 2nd    "       "      ( >= jpjglo ) 
     27#if key_levels == 1  
     28      jpkdta  = 2,           &  !: 1 level run  
     29#else  
    2730      jpkdta  = 31              !: number of levels      ( >= jpk    )  
     31#endif 
    2832 
    2933#if defined key_antarctic 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_ORCA_R4.h90

    r7363 r7367  
    2424      jpidta  =  92   ,      &  !: first horizontal dimension > or = to jpi 
    2525      jpjdta  =  76   ,      &  !: second                     > or = to jpj 
     26#if key_levels == 1  
     27      jpkdta  = 2,           &  !: 1 level run  
     28#else  
    2629      jpkdta  =  31   ,      &  !: number of levels           > or = to jpk 
     30#endif 
    2731      ! global domain matrix size 
    2832      jpiglo  = jpidta,      &  !: first  dimension of global domain --> i 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_POMME_R025.h90

    r7363 r7367  
    3232      jpidta  = ( jpi_ie - jpi_iw + 1 ), &   !: =30 first horizontal dimension > or = to jpi 
    3333      jpjdta  = ( jpj_jn - jpj_js + 1 ), &   !: =40 second                     > or = to jpj 
     34#if key_levels == 1  
     35      jpkdta  = 2,           &  !: 1 level run  
     36#else  
    3437      jpkdta  = 46 ,         &  !: number of levels           > or = to jpk 
     38#endif 
    3539      ! total domain matrix size 
    3640      jpiglo  = jpidta,      &  !: first  dimension of global domain --> i 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/par_oce.F90

    r7363 r7367  
    7676   !!--------------------------------------------------------------------- 
    7777#             include "par_GYRE.h90" 
     78#elif defined key_ind_r12  
     79   !!---------------------------------------------------------------------  
     80   !!   'key_ind_r12'    :                Indian Ocean 1/12 degree : IND12  
     81   !!---------------------------------------------------------------------  
     82#             include "par_IND_R12.h90"  
     83#elif defined key_med_r12  
     84   !!---------------------------------------------------------------------  
     85   !!   'key_med_r12'    :               Mediterranean 1/12 degree : MED12  
     86   !!---------------------------------------------------------------------  
     87#             include "par_MED_R12.h90"  
     88#elif defined key_natl_r12  
     89   !!---------------------------------------------------------------------  
     90   !!   'key_natl_r12'    :   N Atlantic 1/12 deg (rot lat/lon) :   NATL12  
     91   !!---------------------------------------------------------------------  
     92#             include "par_NATL_R12.h90"  
     93#elif defined key_amm   
     94   !!---------------------------------------------------------------------   
     95   !!   'key_amm'         :   Atlantic Margin Model (~7km)     :      AMM   
     96   !!---------------------------------------------------------------------   
     97#             include "par_AMM.h90"   
    7898#elif defined key_pomme_r025 
    7999   !!--------------------------------------------------------------------- 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/step.F90

    r7363 r7367  
    148148         IF( ln_traldf_grif ) THEN                           ! before slope for Griffies operator 
    149149                         CALL ldf_slp_grif( kstp ) 
    150          ELSE 
     150         ENDIF 
     151         !ELSE 
    151152                         CALL ldf_slp( kstp, rhd, rn2b )     ! before slope for Madec operator 
    152          ENDIF 
     153         !ENDIF 
    153154      ENDIF 
    154155#if defined key_traldf_c2d 
    … …  
    160161      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    161162      IF( lk_floats  )   CALL flo_stp( kstp )         ! drifting Floats 
     163      IF( lk_diacfl  )   CALL dia_cfl( kstp )                 ! Courant number diagnostics   
     164      IF( lk_diamke .AND. kstp == nitend )  CALL dia_mke( )   ! Kinetic Energy diagnostics   
    162165      IF( lk_diahth  )   CALL dia_hth( kstp )         ! Thermocline depth (20 degres isotherm depth) 
    163166      IF( lk_diafwb  )   CALL dia_fwb( kstp )         ! Fresh water budget diagnostics 
    … …  
    165168      IF( lk_diadct  )   CALL dia_dct( kstp )         ! Transports 
    166169      IF( lk_diaar5  )   CALL dia_ar5( kstp )         ! ar5 diag 
     170      IF( ln_depwri  )   CALL dep_wri( kstp )         ! write depths 
    167171      IF( lk_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis 
    168172                         CALL dia_wri( kstp )         ! ocean model: outputs 
    … …  
    184188                             CALL tra_sbc    ( kstp )       ! surface boundary condition 
    185189      IF( ln_traqsr      )   CALL tra_qsr    ( kstp )       ! penetrative solar radiation qsr 
     190      IF( ln_tradwl      )   CALL tra_dwl    ( kstp )       ! Polcoms Style Short Wave Radiation   
    186191      IF( ln_trabbc      )   CALL tra_bbc    ( kstp )       ! bottom heat flux 
    187192      IF( lk_trabbl      )   CALL tra_bbl    ( kstp )       ! advective (and/or diffusive) bottom boundary layer scheme 
    … …  
    218223      IF(  ln_asmiau .AND. & 
    219224         & ln_dyninc       )   CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
     225      IF( ln_bkgwri )          CALL asm_bkg_wri( kstp )     ! output background fields  
    220226      IF( ln_neptsimp )        CALL dyn_nept_cor( kstp )    ! subtract Neptune velocities (simplified) 
    221227                               CALL dyn_adv( kstp )         ! advection (vector or flux form) 
    222228                               CALL dyn_vor( kstp )         ! vorticity term including Coriolis 
    223229                               CALL dyn_ldf( kstp )         ! lateral mixing 
     230      IF ( ln_shelf_flx )      CALL inv( kstp )             ! modification to vel from atmos pres  
    224231      IF( ln_neptsimp )        CALL dyn_nept_cor( kstp )    ! add Neptune velocities (simplified) 
    225232#if defined key_agrif 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r7363 r7367  
    2020   USE sbcrnf           ! surface boundary condition: runoff variables 
    2121   USE sbccpl           ! surface boundary condition: coupled formulation (call send at end of step) 
     22   USE sbcflx           ! surface boundary condition: Fluxes 
    2223   USE cpl_oasis3, ONLY : lk_cpl 
    2324   USE sbctide          ! Tide initialisation 
    2425 
    2526   USE traqsr           ! solar radiation penetration      (tra_qsr routine) 
     27   USE tradwl           ! POLCOMS style solar radiation    (tra_dwl routine)   
    2628   USE trasbc           ! surface boundary condition       (tra_sbc routine) 
    2729   USE trabbc           ! bottom boundary condition        (tra_bbc routine) 
    … …  
    5860 
    5961   USE sshwzv           ! vertical velocity and ssh        (ssh_wzv routine) 
     62   USE inv_bar_vel_mod  ! Atmos press effect on vel  
    6063 
    6164   USE ldfslp           ! iso-neutral slopes               (ldf_slp routine) 
    … …  
    7477   USE zpshde           ! partial step: hor. derivative     (zps_hde routine) 
    7578 
     79   USE depwri           ! Write depths to NetCDF           (dep_wri routine)  
    7680   USE diawri           ! Standard run outputs             (dia_wri routine) 
     81   USE diafoam          ! Met Office FOAM diagnostics  
    7782   USE trdicp           ! Ocean momentum/tracers trends    (trd_wri routine) 
    7883   USE trdmld           ! mixed-layer trends               (trd_mld routine) 
    … …  
    8186   USE trdmod           ! momentum/tracers trends    
    8287   USE trdvor           ! vorticity budget                 (trd_vor routine) 
     88 
     89   USE diacfl           ! output CFL diagnostics           (dia_cfl routine)   
     90   USE diamke           ! Kinetic Energy diagnostics       (dia_mke routine)  
    8391   USE diaptr           ! poleward transports              (dia_ptr routine) 
    8492   USE diadct           ! sections transports              (dia_dct routine) 
    … …  
    93101   USE asminc           ! assimilation increments      (tra_asm_inc routine) 
    94102   !                                                   (dyn_asm_inc routine) 
    95  
     103   USE asmtrj           ! assimilation trajectory      (asm_bkg_wri routine)  
     104       
    96105   USE stpctl           ! time stepping control            (stp_ctl routine) 
    97106   USE restart          ! ocean restart                    (rst_wri routine) 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/timing.F90

    r7363 r7367  
    7676   LOGICAL :: ln_onefile = .TRUE.  
    7777   LOGICAL :: lwriter 
    78  
    7978   !!---------------------------------------------------------------------- 
    8079   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    … …  
    322321      IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' 
    323322      IF( lwriter ) WRITE(numtime,*) '--------------------' 
    324       IF( lwriter ) WRITE(numtime,*) 'Elapsed Time (s)  ','CPU Time (s)' 
    325       IF( lwriter ) WRITE(numtime,'(5x,f12.3,2x,f12.3)')  tot_etime, tot_ctime 
     323      IF( lwriter ) WRITE(numtime,"('Elapsed Time (s)  CPU Time (s)')") 
     324      IF( lwriter ) WRITE(numtime,'(5x,f12.3,1x,f12.3)')  tot_etime, tot_ctime 
    326325      IF( lwriter ) WRITE(numtime,*)  
    327326#if defined key_mpp_mpi 
    … …  
    406405      TYPE(timer), POINTER :: sl_timer_ave      => NULL() 
    407406      INTEGER :: icode 
     407      INTEGER :: ierr 
    408408      LOGICAL :: ll_ord            
    409409      CHARACTER(len=200) :: clfmt               
    410410                  
    411411      ! Initialised the global strucutre    
    412       ALLOCATE(sl_timer_glob_root) 
    413       ALLOCATE(sl_timer_glob_root%cname     (jpnij)) 
    414       ALLOCATE(sl_timer_glob_root%tsum_cpu  (jpnij)) 
    415       ALLOCATE(sl_timer_glob_root%tsum_clock(jpnij)) 
    416       ALLOCATE(sl_timer_glob_root%niter     (jpnij)) 
     412      ALLOCATE(sl_timer_glob_root, Stat=ierr) 
     413      IF(ierr /= 0)THEN 
     414         WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' 
     415         RETURN 
     416      END IF 
     417 
     418      ALLOCATE(sl_timer_glob_root%cname     (jpnij), & 
     419               sl_timer_glob_root%tsum_cpu  (jpnij), & 
     420               sl_timer_glob_root%tsum_clock(jpnij), & 
     421               sl_timer_glob_root%niter     (jpnij), Stat=ierr) 
     422      IF(ierr /= 0)THEN 
     423         WRITE(numtime,*) 'Failed to allocate global timing structure in waver_info' 
     424         RETURN 
     425      END IF 
    417426      sl_timer_glob_root%cname(:)       = '' 
    418427      sl_timer_glob_root%tsum_cpu(:)   = 0._wp 
    … …  
    421430      sl_timer_glob_root%next => NULL() 
    422431      sl_timer_glob_root%prev => NULL() 
    423       ALLOCATE(sl_timer_glob) 
    424       ALLOCATE(sl_timer_glob%cname     (jpnij)) 
    425       ALLOCATE(sl_timer_glob%tsum_cpu  (jpnij)) 
    426       ALLOCATE(sl_timer_glob%tsum_clock(jpnij)) 
    427       ALLOCATE(sl_timer_glob%niter     (jpnij)) 
     432      !ARPDBG - don't need to allocate a pointer that's immediately then 
     433      !         set to point to some other object. 
     434      !ALLOCATE(sl_timer_glob) 
     435      !ALLOCATE(sl_timer_glob%cname     (jpnij)) 
     436      !ALLOCATE(sl_timer_glob%tsum_cpu  (jpnij)) 
     437      !ALLOCATE(sl_timer_glob%tsum_clock(jpnij)) 
     438      !ALLOCATE(sl_timer_glob%niter     (jpnij)) 
    428439      sl_timer_glob => sl_timer_glob_root 
    429440      ! 
    … …  
    451462         sl_timer_ave => sl_timer_ave_root             
    452463      ENDIF  
    453        
     464 
    454465      ! Gather info from all processors 
    455466      s_timer => s_timer_root 
    … …  
    467478                         sl_timer_glob%niter, 1, MPI_INTEGER,   & 
    468479                         0, MPI_COMM_OPA, icode) 
     480 
    469481         IF( narea == 1 .AND. ASSOCIATED(s_timer%next) ) THEN 
    470482            ALLOCATE(sl_timer_glob%next) 
    … …  
    479491         s_timer => s_timer%next 
    480492      END DO       
     493 
     494         WRITE(*,*) 'ARPDBG: timing: done gathers' 
    481495       
    482496      IF( narea == 1 ) THEN     
    … …  
    500514            ENDIF 
    501515            sl_timer_glob => sl_timer_glob%next                                 
    502          END DO          
     516         END DO 
     517 
     518         WRITE(*,*) 'ARPDBG: timing: done computing stats' 
    503519       
    504          ! reorder the avearged list by CPU time       
     520         ! reorder the averaged list by CPU time       
    505521         s_wrk => NULL() 
    506522         sl_timer_ave => sl_timer_ave_root 
    … …  
    509525            sl_timer_ave => sl_timer_ave_root 
    510526            DO WHILE( ASSOCIATED( sl_timer_ave%next ) ) 
    511             IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT 
     527 
     528               IF( .NOT. ASSOCIATED(sl_timer_ave%next) ) EXIT 
     529 
    512530               IF ( sl_timer_ave%tsum_clock < sl_timer_ave%next%tsum_clock ) THEN  
    513531                  ALLOCATE(s_wrk) 
     532                  ! Copy data into the new object pointed to by s_wrk 
    514533                  s_wrk = sl_timer_ave%next 
     534                  ! Insert this new timer object before our current position 
    515535                  CALL insert  (sl_timer_ave, sl_timer_ave_root, s_wrk) 
     536                  ! Remove the old object from the list 
    516537                  CALL suppress(sl_timer_ave%next)             
    517538                  ll_ord = .FALSE. 
    518539                  CYCLE             
    519540               ENDIF            
    520             IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next 
     541               IF( ASSOCIATED(sl_timer_ave%next) ) sl_timer_ave => sl_timer_ave%next 
    521542            END DO          
    522            IF( ll_ord ) EXIT 
     543            IF( ll_ord ) EXIT 
    523544         END DO 
    524545 
    525546         ! write averaged info 
    526          WRITE(numtime,*) 'Averaged timing on all processors :' 
    527          WRITE(numtime,*) '-----------------------------------' 
    528          WRITE(numtime,*) 'Section             ',                & 
    529          &   'Elapsed Time (s)  ','Elapsed Time (%)  ',          & 
    530          &   'CPU Time(s)  ','CPU Time (%)  ','CPU/Elapsed  ',   & 
    531          &   'Max Elapsed (%)  ','Min elapsed (%)  ',            &            
    532          &   'Frequency'  
     547         WRITE(numtime,"('Averaged timing on all processors :')") 
     548         WRITE(numtime,"('-----------------------------------')") 
     549         WRITE(numtime,"('Section',13x,'Elap. Time(s)',2x,'Elap. Time(%)',2x, & 
     550         &   'CPU Time(s)',2x,'CPU Time(%)',2x,'CPU/Elap',1x,   & 
     551         &   'Max elap(%)',2x,'Min elap(%)',2x,            &            
     552         &   'Freq')") 
    533553         sl_timer_ave => sl_timer_ave_root   
    534          clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,5x,f12.3,5x,f12.3,2x,f9.2)' 
     554         clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' 
    535555         DO WHILE ( ASSOCIATED(sl_timer_ave) ) 
    536             WRITE(numtime,TRIM(clfmt))   sl_timer_ave%cname,                            & 
     556            WRITE(numtime,TRIM(clfmt))   sl_timer_ave%cname(1:18),                            & 
    537557            &   sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime,   & 
    538558            &   sl_timer_ave%tsum_cpu  ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime  ,   & 
    … …  
    712732      !!---------------------------------------------------------------------- 
    713733      l_initdone = .TRUE.  
    714       IF(lwp) WRITE(numout,*) 
    715       IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing' 
    716       IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    717       CALL timing_list(s_timer_root) 
    718       WRITE(numout,*) 
     734!      IF(lwp) WRITE(numout,*) 
     735!      IF(lwp) WRITE(numout,*) 'timing_reset : instrumented routines for timing' 
     736!      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     737!      CALL timing_list(s_timer_root) 
     738!      WRITE(numout,*) 
    719739      ! 
    720740   END SUBROUTINE timing_reset 
    … …  
    734754      !!---------------------------------------------------------------------- 
    735755      !!               ***  ROUTINE insert  *** 
    736       !! ** Purpose :   insert an element in  imer structure 
     756      !! ** Purpose :   insert an element in timer structure 
    737757      !!---------------------------------------------------------------------- 
    738758      TYPE(timer), POINTER, INTENT(inout) :: sd_current, sd_root, sd_ptr 
    … …  
    740760      
    741761      IF( ASSOCIATED( sd_current, sd_root ) ) THEN 
     762         ! If our current element is the root element then 
     763         ! replace it with the one being inserted 
    742764         sd_root => sd_ptr 
    743765      ELSE 
    … …  
    747769      sd_ptr%prev     => sd_current%prev 
    748770      sd_current%prev => sd_ptr 
     771      ! Nullify the pointer to the new element now that it is held 
     772      ! within the list. If we don't do this then a subsequent call 
     773      ! to ALLOCATE memory to this pointer will fail. 
     774      sd_ptr => NULL() 
    749775      !     
    750776   END SUBROUTINE insert 
    … …  
    764790      IF ( ASSOCIATED(sl_temp%next) ) sl_temp%next%prev => sl_temp%prev 
    765791      DEALLOCATE(sl_temp) 
     792      sl_temp => NULL() 
    766793      ! 
    767794    END SUBROUTINE suppress 

  • branches/UKMO/CO5_package_branch/NEMOGCM/NEMO/OPA_SRC/trc_oce.F90

    r7363 r7367  
    2626   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   etot3   !: light absortion coefficient 
    2727   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   facvol   !: volume for degraded regions 
     28   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   rlambda2 !: Lambda2 for downwell version of Short wave Radiation  
     29   REAL(wp), PUBLIC                                      ::   rlambda  !: Lambda  for downwell version of Short wave Radiation 
    2830 
    2931#if defined key_top && defined key_pisces 
    … …  
    7577      !!                  ***  trc_oce_alloc  *** 
    7678      !!---------------------------------------------------------------------- 
    77       INTEGER ::   ierr(2)        ! Local variables 
     79      INTEGER ::   ierr(3)        ! Local variables 
    7880      !!---------------------------------------------------------------------- 
    7981      ierr(:) = 0 
    80                      ALLOCATE( etot3 (jpi,jpj,jpk), STAT=ierr(1) ) 
    81       IF( lk_degrad) ALLOCATE( facvol(jpi,jpj,jpk), STAT=ierr(2) ) 
     82                     ALLOCATE(   etot3 (jpi,jpj,jpk), STAT=ierr(1) ) 
     83      IF( lk_degrad) ALLOCATE(   facvol(jpi,jpj,jpk), STAT=ierr(2) ) 
     84                     ALLOCATE( rlambda2(jpi,jpj),     STAT=ierr(3) ) 
    8285      trc_oce_alloc  = MAXVAL( ierr ) 
    8386      ! 
    84       IF( trc_oce_alloc /= 0 )   CALL ctl_warn('trc_oce_alloc: failed to allocate etot3 array') 
     87      IF( trc_oce_alloc /= 0 )   CALL ctl_warn('trc_oce_alloc: failed to allocate etot3,facvol or rlambda2 array') 
    8588   END FUNCTION trc_oce_alloc 
    8689 
Note: See TracChangeset for help on using the changeset viewer.