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.
trcsbcssr.F90 in branches/UKMO/CO6_KD490_amm7_oper_fabm_chlrelax/NEMOGCM/NEMO/TOP_SRC/TRP – NEMO

source: branches/UKMO/CO6_KD490_amm7_oper_fabm_chlrelax/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbcssr.F90 @ 8141

Last change on this file since 8141 was 8141, checked in by dford, 7 years ago

Initial implementation of surface chlorophyll relaxation for FABM-ERSEM.

File size: 8.4 KB
Line 
1MODULE trcsbcssr
2   !!======================================================================
3   !!                       ***  MODULE  trcsbcssr  ***
4   !! Surface module :  restoring term towards surface chlorophyll climatology
5   !!======================================================================
6   !! History :  3.6  !  2017-06  (D. Ford)  Adapt from sbcssr.F90
7   !!----------------------------------------------------------------------
8#if defined key_top
9   !!----------------------------------------------------------------------
10   !!   trc_sbc_ssr       : add a restoring term toward chl climatology
11   !!   trc_sbc_ssr_init  : initialisation of surface restoring
12   !!----------------------------------------------------------------------
13   USE dom_oce        ! ocean space and time domain
14   USE oce_trc       !  shared variables between ocean and passive tracers
15   USE trc
16   USE trcnam_trp
17   !
18   USE fldread        ! read input fields
19   USE iom            ! I/O manager
20   USE in_out_manager ! I/O manager
21   USE lib_mpp        ! distribued memory computing library
22   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
23   USE timing         ! Timing
24   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
25#if defined key_fabm
26   USE par_fabm
27#endif
28
29   IMPLICIT NONE
30   PRIVATE
31
32   PUBLIC   trc_sbc_ssr        ! routine called in trctrp
33
34   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_chldmp   ! structure of input Chl (file informations, fields read)
35
36   !! * Substitutions
37#  include "top_substitute.h90"
38
39CONTAINS
40
41   SUBROUTINE trc_sbc_ssr( kt )
42      !!---------------------------------------------------------------------
43      !!                     ***  ROUTINE trc_sbc_ssr  ***
44      !!
45      !! ** Purpose :   Add to chlorophyll a damping term
46      !!                toward chlorophyll climatology
47      !!
48      !! ** Method  : - Read chlorophyll climatology
49      !!              - at each trc time step add term to each PFT
50      !!                   surface only    (nn_chldmp = 1)
51      !!                   mixed layer     (nn_chldmp = 2)
52      !!---------------------------------------------------------------------
53      INTEGER, INTENT(in   ) ::   kt   ! ocean time step
54      !!
55      INTEGER  ::   ji, jj, jk   ! dummy loop indices
56 
57      REAL(wp), DIMENSION(jpi,jpj) :: ztra, zchl
58      REAL(wp)                     :: zpft
59      !!----------------------------------------------------------------------
60      !
61      IF( nn_timing == 1 )  CALL timing_start('trc_sbc_ssr')
62      !
63      IF( kt == nittrc000 )  THEN
64         !
65         CALL trc_sbc_ssr_init
66         !
67         IF( nn_chldmp > 0 ) THEN
68            !
69            IF (lwp) WRITE(numout,*) 'Damping chlorophyll on timestep ', kt
70            !
71            CALL fld_read( kt, 1, sf_chldmp )   ! Read Chl data and provides it at kt
72            !
73#if defined key_fabm
74            zchl(:,:) = trb(:,:,1,jp_fabm_m1+jp_fabm_chl1) + &
75               &        trb(:,:,1,jp_fabm_m1+jp_fabm_chl2) + &
76               &        trb(:,:,1,jp_fabm_m1+jp_fabm_chl3) + &
77               &        trb(:,:,1,jp_fabm_m1+jp_fabm_chl4)
78            ztra(:,:) = rn_chldmp * ( sf_chldmp(1)%fnow(:,:,1) - zchl(:,:) )
79            !
80            DO jj = 2, jpjm1
81               DO ji = fs_2, fs_jpim1   ! vector opt.
82                  IF ( ( sf_chldmp(1)%fnow(ji,jj,1) >   0.0 ) .AND. &
83                     & ( sf_chldmp(1)%fnow(ji,jj,1) < 100.0 ) .AND. &
84                     & ( zchl(ji,jj)                >   0.0 ) ) THEN
85                     WRITE(numout,'(A,3I,3F)') 'ssr, nproc, ji, jj, zchl, sf, ztra = ', nproc, ji, jj, zchl(ji,jj), sf_chldmp(1)%fnow(ji,jj,1), ztra(ji,jj)
86                     zpft = ( trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl1) / zchl(ji,jj) ) * ztra(ji,jj)
87                     tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl1) = tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl1) + zpft
88                     WRITE(numout,'(A,3I,2F)') 'ssr, nproc, ji, jj, trb1, zpft1 = ', nproc, ji, jj, trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl1), zpft
89                     IF( nn_chldmp == 2 ) THEN
90                        DO jk = 2, jpkm1
91                           IF( fsdept(ji,jj,jk) < hmlp (ji,jj) ) THEN
92                              tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl1) = tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl1) + zpft
93                           ENDIF
94                        END DO
95                     ENDIF
96                     !
97                     zpft = ( trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl2) / zchl(ji,jj) ) * ztra(ji,jj)
98                     tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl2) = tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl2) + zpft
99                     WRITE(numout,'(A,3I,2F)') 'ssr, nproc, ji, jj, trb2, zpft2 = ', nproc, ji, jj, trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl2), zpft
100                     IF( nn_chldmp == 2 ) THEN
101                        DO jk = 2, jpkm1
102                           IF( fsdept(ji,jj,jk) < hmlp (ji,jj) ) THEN
103                              tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl2) = tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl2) + zpft
104                           ENDIF
105                        END DO
106                     ENDIF
107                     !
108                     zpft = ( trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl3) / zchl(ji,jj) ) * ztra(ji,jj)
109                     tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl3) = tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl3) + zpft
110                     WRITE(numout,'(A,3I,2F)') 'ssr, nproc, ji, jj, trb3, zpft3 = ', nproc, ji, jj, trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl3), zpft
111                     IF( nn_chldmp == 2 ) THEN
112                        DO jk = 2, jpkm1
113                           IF( fsdept(ji,jj,jk) < hmlp (ji,jj) ) THEN
114                              tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl3) = tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl3) + zpft
115                           ENDIF
116                        END DO
117                     ENDIF
118                     !
119                     zpft = ( trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl4) / zchl(ji,jj) ) * ztra(ji,jj)
120                     tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl4) = tra(ji,jj,1,jp_fabm_m1+jp_fabm_chl4) + zpft
121                     WRITE(numout,'(A,3I,2F)') 'ssr, nproc, ji, jj, trb4, zpft4 = ', nproc, ji, jj, trb(ji,jj,1,jp_fabm_m1+jp_fabm_chl4), zpft
122                     IF( nn_chldmp == 2 ) THEN
123                        DO jk = 2, jpkm1
124                           IF( fsdept(ji,jj,jk) < hmlp (ji,jj) ) THEN
125                              tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl4) = tra(ji,jj,jk,jp_fabm_m1+jp_fabm_chl4) + zpft
126                           ENDIF
127                        END DO
128                     ENDIF
129                  ENDIF
130               END DO
131            END DO
132#else
133            CALL ctl_stop( 'STOP', 'trc_sbc_ssr: only works with FABM-ERSEM' )
134#endif
135            !
136         ENDIF
137         !
138      ENDIF
139      !
140      IF( nn_timing == 1 )  CALL timing_stop('trc_sbc_ssr')
141      !
142   END SUBROUTINE trc_sbc_ssr
143
144 
145   SUBROUTINE trc_sbc_ssr_init
146      !!---------------------------------------------------------------------
147      !!                  ***  ROUTINE trc_sbc_ssr_init  ***
148      !!
149      !! ** Purpose :   initialisation of surface damping term
150      !!
151      !! ** Method  : - Read chlorophyll
152      !!---------------------------------------------------------------------
153      INTEGER  ::   ierror   ! return error code
154      !!----------------------------------------------------------------------
155      !
156      IF( nn_chldmp > 0 ) THEN      !* set sf_sss structure & allocate arrays
157         !
158         ALLOCATE( sf_chldmp(1), STAT=ierror )
159         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'trc_sbc_ssr: unable to allocate sf_chldmp structure' )
160         ALLOCATE( sf_chldmp(1)%fnow(jpi,jpj,1), STAT=ierror )
161         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'trc_sbc_ssr: unable to allocate sf_chldmp now array' )
162         !
163         ! fill sf_sss with sn_sss and control print
164         CALL fld_fill( sf_chldmp, (/ sn_chldmp /), cn_dir_chldmp, 'trc_sbc_ssr', 'Chl restoring term', 'namtrc_dmp' )
165         IF( sf_chldmp(1)%ln_tint )   ALLOCATE( sf_chldmp(1)%fdta(jpi,jpj,1,2), STAT=ierror )
166         IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'trc_sbc_ssr: unable to allocate sf_chldmp data array' )
167         !
168      ENDIF
169      !
170   END SUBROUTINE trc_sbc_ssr_init
171
172#else
173   SUBROUTINE trc_sbc_ssr( kt )        ! Empty routine
174      INTEGER, INTENT(in) :: kt
175      WRITE(*,*) 'trc_sbc_ssr: You should not have seen this print! error?', kt
176   END SUBROUTINE trc_sbc_ssr
177#endif
178   !!======================================================================
179END MODULE trcsbcssr
Note: See TracBrowser for help on using the repository browser.