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

Changeset 775


Ignore:
Timestamp:
2007-12-19T14:45:15+01:00 (16 years ago)
Author:
gm
Message:

dev_001_GM - PISCES in F90 : encapsulation of all p4z...F files in module F90 + doctor norme for local variables - compilation OK

Location:
branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS
Files:
2 deleted
21 moved

Legend:

Unmodified
Added
Removed

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zbio.F90

    r774 r775  
    1  
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6       SUBROUTINE p4zbio 
    7 CDIR$ LIST 
    8 #if defined key_top && defined key_pisces 
    9 CCC   ------------------------------------------------------------------ 
    10 CCC    
    11 CCC   ROUTINE p4zbio : PISCES MODEL 
    12 CCC   ***************************** 
    13 CCC    
    14 CC 
    15 CC     PURPOSE. 
    16 CC     -------- 
    17 CC          *P4ZBIO* ECOSYSTEM MODEL IN THE WHOLE OCEAN 
    18 CC                   THIS ROUTINE COMPUTES THE DIFFERENT INTERACTIONS 
    19 CC                   BETWEEN THE DIFFERENT COMPARTMENTS OF THE MODEL 
    20 CC     EXTERNAL : 
    21 CC     ---------- 
    22 CC          p4zopt, p4zprod, p4znano, p4zdiat, p4zmicro, p4zmeso 
    23 CC          p4zsink, p4zrem 
    24 CC 
    25 CC   MODIFICATIONS: 
    26 CC   -------------- 
    27 CC      original      : 2004    O. Aumont 
    28 CC ---------------------------------------------------------------- 
    29 CC parameters and commons 
    30 CC ====================== 
    31 CDIR$ NOLIST 
    32       USE oce_trc 
    33       USE trp_trc 
    34       USE sms 
    35       IMPLICIT NONE 
    36 #include "domzgr_substitute.h90" 
    37 CDIR$ LIST 
    38 CC----------------------------------------------------------------- 
    39 CC local declarations 
    40 CC ================== 
    41 C      
    42       INTEGER ji, jj, jk, jn 
    43  
    44       REAL zdenom,zdenom1(jpi,jpj,jpk) 
    45       REAL prodca,ztemp 
    46  
     1MODULE p4zbio 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zbio  *** 
     4   !! TOP :   PISCES bio-model 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_bio        :   computes the interactions between the different 
     14   !!                      compartments of PISCES 
     15   !!---------------------------------------------------------------------- 
     16   USE oce_trc         ! 
     17   USE trp_trc         !  
     18   USE sms             !  
     19   USE p4zsink         !  
     20   USE p4zsink_kriest  !  
     21   USE p4zopt          !  
     22   USE p4zlim          !  
     23   USE p4zprod         ! 
     24   USE p4znano         ! 
     25   USE p4zdiat         !  
     26   USE p4zmicro        !  
     27   USE p4zmeso         !  
     28   USE p4zrem          !  
     29    
     30   IMPLICIT NONE 
     31   PRIVATE 
     32 
     33   PUBLIC   p4z_bio    ! called in p4zprg.F90 
     34 
     35   !!* Substitution 
     36#  include "domzgr_substitute.h90" 
     37   !!---------------------------------------------------------------------- 
     38   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     39   !! $Header:$  
     40   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     41   !!---------------------------------------------------------------------- 
     42 
     43CONTAINS 
     44 
     45   SUBROUTINE p4z_bio 
     46      !!--------------------------------------------------------------------- 
     47      !!                     ***  ROUTINE p4z_bio  *** 
     48      !! 
     49      !! ** Purpose :   Ecosystem model in the whole ocean: computes the 
     50      !!              different interactions between the different compartments 
     51      !!              of PISCES 
     52      !! 
     53      !! ** Method  : - ??? 
     54      !!--------------------------------------------------------------------- 
     55      INTEGER  ::   ji, jj, jk, jn 
     56      REAL(wp) ::   zdenom, ztemp 
     57      REAL(wp) ::   zprodt, zprodca 
     58      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdenom1 
     59      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zfracal 
     60#if defined key_kriest 
     61      REAL(wp) ::   znumpoc, znumdoc 
     62#else 
     63      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdenom2 
     64#endif 
     65      !!--------------------------------------------------------------------- 
     66 
     67      !     ASSIGN THE SHEAR RATE THAT IS USED FOR AGGREGATION 
     68      !     OF PHYTOPLANKTON AND DETRITUS 
     69 
     70      zdiss(:,:,:) = 0.01 
     71 
     72!!gm the use of nmld should be better here? 
     73      DO jk = 1, jpkm1 
     74         DO jj = 1, jpj 
     75            DO ji = 1, jpi 
     76               IF( fsdepw(ji,jj,jk+1) .le. hmld(ji,jj) )   zdiss(ji,jj,jk) = 1.e0 
     77            END DO  
     78         END DO 
     79      END DO 
     80 
     81      ! Compute de different ratios for scavenging of iron 
     82      ! -------------------------------------------------- 
     83 
     84      DO jk = 1, jpk 
     85         DO jj = 1, jpj 
     86            DO ji = 1, jpi 
    4787#if ! defined key_kriest 
    48       REAL zdenom2(jpi,jpj,jpk) 
     88               zdenom = 1. / (  trn(ji,jj,jk,jppoc) + trn(ji,jj,jk,jpgoc)           & 
     89                  &           + trn(ji,jj,jk,jpdsi) + trn(ji,jj,jk,jpcal) + rtrn ) 
     90               zdenom1(ji,jj,jk) = trn(ji,jj,jk,jppoc) * zdenom 
     91               zdenom2(ji,jj,jk) = trn(ji,jj,jk,jpgoc) * zdenom 
    4992#else 
    50       REAL znumpoc, znumdoc 
     93               zdenom = 1. / (  trn(ji,jj,jk,jppoc)                                 & 
     94                  &           + trn(ji,jj,jk,jpdsi) + trn(ji,jj,jk,jpcal) + rtrn ) 
     95               zdenom1(ji,jj,jk) = trn(ji,jj,jk,jppoc) * zdenom 
    5196#endif 
    52 C      
    53       REAL prodt 
    54       REAL zfracal(jpi,jpj,jpk) 
    55 C 
    56 C     ASSIGN THE SHEAR RATE THAT IS USED FOR AGGREGATION 
    57 C     OF PHYTOPLANKTON AND DETRITUS 
    58 C 
    59        zdiss(:,:,:) = 0.01 
    60 C 
    61       DO jk=1,jpkm1 
    62         DO jj=1,jpj 
    63           DO ji=1,jpi 
    64        if (fsdepw(ji,jj,jk+1).le.hmld(ji,jj)) zdiss(ji,jj,jk)=1. 
    65           END DO  
    66         END DO 
    67       END DO 
    68 C 
    69 C      Compute de different ratios for scavenging of iron 
    70 C      -------------------------------------------------- 
    71 C 
    72        DO jk=1,jpk 
    73          DO jj=1,jpj 
    74            DO ji=1,jpi 
    75 #if ! defined key_kriest 
    76          zdenom=1./(trn(ji,jj,jk,jppoc)+trn(ji,jj,jk,jpgoc) 
    77      $     +trn(ji,jj,jk,jpdsi)+trn(ji,jj,jk,jpcal)+rtrn) 
    78 C 
    79          zdenom1(ji,jj,jk)=trn(ji,jj,jk,jppoc)*zdenom 
    80          zdenom2(ji,jj,jk)=trn(ji,jj,jk,jpgoc)*zdenom 
     97            END DO 
     98         END DO 
     99      END DO 
     100 
     101      ! Compute the fraction of nanophytoplankton that is made of calcifiers 
     102      ! -------------------------------------------------------------------- 
     103 
     104      DO jk = 1, jpkm1 
     105         DO jj = 1, jpj 
     106            DO ji = 1, jpi 
     107               ztemp = MAX( 0., tn(ji,jj,jk) ) 
     108               zfracal(ji,jj,jk) = caco3r * xlimphy(ji,jj,jk)   & 
     109                  &                       * MAX( 0.0001, ztemp / ( 2.+ ztemp ) )   & 
     110                  &                       * MAX( 1., trn(ji,jj,jk,jpphy) * 1.e6 / 2. ) 
     111               zfracal(ji,jj,jk) = MIN( 0.8 , zfracal(ji,jj,jk) ) 
     112               zfracal(ji,jj,jk) = MAX( 0.01, zfracal(ji,jj,jk) ) 
     113            END DO 
     114         END DO 
     115      END DO 
     116 
     117      ! computation of the vertical flux of particulate organic matter 
     118      ! -------------------------------------------------------------- 
     119 
     120      IF( lk_kriest )   THEN   ;   CALL p4z_sink_kriest      ! Sink due to vertical flux of POM 
     121      ELSE                     ;   CALL p4z_sink             !  
     122      ENDIF 
     123 
     124      ! compute the PAR in the water column 
     125      ! ----------------------------------- 
     126 
     127      CALL p4z_opt       ! Optical  
     128 
     129      ! compute the co-limitations by the various nutrients 
     130      ! ---------------------------------------------------- 
     131 
     132      CALL p4z_lim 
     133 
     134      ! compute phytoplankton growth rate over the global ocean.  
     135      ! ------------------------------------------------------- 
     136      ! (Growth rates for each element is computed (C, Si, Fe, Chl)) 
     137 
     138      CALL p4z_prod 
     139 
     140      ! phytoplankton mortality (Mortality losses for each elements are computed (C, Fe, Si, Chl) ) 
     141      ! ----------------------- 
     142 
     143      CALL p4z_nano       ! nanophytoplankton 
     144       
     145      CALL p4z_diat       ! diatoms 
     146 
     147      ! zooplankton sources/sinks routines (each elements are computed (C, Fe, Si, Chl) ) 
     148      ! ---------------------------------- 
     149 
     150      CALL p4z_micro      ! microzooplankton 
     151       
     152      CALL p4z_meso       ! mesozooplankton 
     153 
     154      ! computation of remineralization terms of organic matter + scavenging of Fe 
     155      ! -------------------------------------------------------------------------- 
     156       
     157      CALL p4z_rem        ! remineralization 
     158 
     159 
     160      ! Determination of tracers concentration as a function of biological sources and sinks 
     161      ! ------------------------------------------------------------------------------------ 
     162 
     163      DO jk = 1, jpkm1 
     164 
     165         ! Evolution of PO4 
     166         ! ----------------     
     167         trn(:,:,jk,jppo4) = trn(:,:,jk,jppo4) - prorca(:,:,jk) - prorca2(:,:,jk)            & 
     168            &                                  + olimi (:,:,jk) + grarem (:,:,jk) * sigma1   & 
     169            &                                  + denitr(:,:,jk) + grarem2(:,:,jk) * sigma2 
     170 
     171         ! Evolution of NO3 and NH4 
     172         ! ------------------------ 
     173         trn(:,:,jk,jpno3) = trn(:,:,jk,jpno3) - pronew(:,:,jk) - pronew2(:,:,jk)            & 
     174            &                                  + onitr (:,:,jk) - denitr (:,:,jk) * rdenit 
     175 
     176         trn(:,:,jk,jpnh4) = trn(:,:,jk,jpnh4) - proreg(:,:,jk) - proreg2(:,:,jk)            & 
     177            &                                  + olimi (:,:,jk) + grarem (:,:,jk) * sigma1   & 
     178            &                                                   + grarem2(:,:,jk) * sigma2   & 
     179            &                                  - onitr (:,:,jk) + denitr (:,:,jk) 
     180 
     181         ! Evolution of Phytoplankton 
     182         ! -------------------------- 
     183         trn(:,:,jk,jpphy) = trn(:,:,jk,jpphy) + prorca (:,:,jk) * ( 1.- excret ) - tortp(:,:,jk)   & 
     184            &                                  - grazp  (:,:,jk) - grazn(:,:,jk)  - respp(:,:,jk) 
     185 
     186         trn(:,:,jk,jpnch) = trn(:,:,jk,jpnch) + prorca6(:,:,jk) * ( 1.- excret ) - tortnch(:,:,jk)   & 
     187            &                                  - grazpch(:,:,jk) - graznch(:,:,jk)- respnch(:,:,jk) 
     188 
     189         ! Evolution of Diatoms 
     190         ! -------------------- 
     191         trn(:,:,jk,jpdia) = trn(:,:,jk,jpdia) + prorca2(:,:,jk) * ( 1.- excret2 ) - tortp2(:,:,jk)   & 
     192            &                                  - respp2 (:,:,jk) - grazd(:,:,jk)   - grazsd(:,:,jk) 
     193 
     194         trn(:,:,jk,jpdch) = trn(:,:,jk,jpdch) + prorca7(:,:,jk) * ( 1.- excret2 ) - tortdch(:,:,jk)   & 
     195            &                                  - respdch(:,:,jk) - grazdch(:,:,jk) - grazsch(:,:,jk) 
     196 
     197         ! Evolution of Zooplankton 
     198         ! ------------------------    
     199         trn(:,:,jk,jpzoo) = trn(:,:,jk,jpzoo) + epsher * ( grazp(:,:,jk) + grazm(:,:,jk) + grazsd(:,:,jk) )   & 
     200            &                                  - grazz(:,:,jk) - tortz(:,:,jk) - respz(:,:,jk) 
     201 
     202         ! Evolution of Mesozooplankton 
     203         ! ------------------------ 
     204         trn(:,:,jk,jpmes) = trn(:,:,jk,jpmes) + epsher2 * (  grazd  (:,:,jk) + grazz  (:,:,jk) + grazn(:,:,jk)   & 
     205            &                                               + grazpoc(:,:,jk) + grazffe(:,:,jk)  )                & 
     206            &                                  - tortz2(:,:,jk) - respz2(:,:,jk) 
     207     
     208         ! Evolution of O2 
     209         ! ---------------      
     210         trn(:,:,jk,jpoxy) = trn(:,:,jk,jpoxy) + o2ut * (  proreg(:,:,jk) + proreg2(:,:,jk) - olimi(:,:,jk)        & 
     211            &                                             -grarem(:,:,jk) * sigma1 - grarem2(:,:,jk) * sigma2  )   & 
     212            &                                  + ( o2ut + o2nit ) * ( pronew(:,:,jk) + pronew2(:,:,jk) )           & 
     213            &                                  - o2nit * onitr(:,:,jk) 
     214 
     215         ! Evolution of IRON 
     216         ! ----------------- 
     217         trn(:,:,jk,jpfer) = trn(:,:,jk,jpfer) + ( excret  - 1.) * prorca5(:,:,jk) - xaggdfe (:,:,jk)   & 
     218            &                                  + ( excret2 - 1.) * prorca4(:,:,jk) - xbactfer(:,:,jk)   & 
     219            &                                  + grafer(:,:,jk) + grafer2(:,:,jk)                       & 
     220            &                                  + ofer  (:,:,jk) - xscave (:,:,jk) 
     221         ! 
     222      END DO 
     223 
     224 
     225#if defined key_kriest 
     226 
     227#include "p4zbio_kriest.h90" 
    81228 
    82229#else 
    83          zdenom=1./(trn(ji,jj,jk,jppoc) 
    84      $     +trn(ji,jj,jk,jpdsi)+trn(ji,jj,jk,jpcal)+rtrn) 
    85          zdenom1(ji,jj,jk)=trn(ji,jj,jk,jppoc)*zdenom 
     230 
     231#include "p4zbio_std.h90" 
    86232 
    87233#endif 
    88            END DO 
    89          END DO 
    90        END DO 
    91 C 
    92 C     Compute the fraction of nanophytoplankton that is made 
    93 C     of calcifiers 
    94 C     ------------------------------------------------------ 
    95 C 
    96        DO jk=1,jpkm1 
    97          DO jj=1,jpj 
    98            DO ji=1,jpi 
    99        ztemp=max(0.,tn(ji,jj,jk)) 
    100        zfracal(ji,jj,jk)=caco3r*xlimphy(ji,jj,jk)*max(0.0001 
    101      &   ,ztemp/(2.+ztemp))*max(1.,trn(ji,jj,jk,jpphy)*1E6/2.) 
    102        zfracal(ji,jj,jk)=min(0.8,zfracal(ji,jj,jk)) 
    103        zfracal(ji,jj,jk)=max(0.01,zfracal(ji,jj,jk)) 
    104            END DO 
    105          END DO 
    106        END DO 
    107  
    108 C 
    109 C     Call subroutine for computation of the vertical flux 
    110 C     of particulate organic matter 
    111 C     ---------------------------------------------------- 
    112 C 
    113       CALL p4zsink 
    114  
    115 C 
    116 C  Call optical routine to compute the PAR in the water column 
    117 C  ----------------------------------------------------------- 
    118 C 
    119       CALL p4zopt 
    120 C 
    121 C  Call routine to compute the co-limitations by the various 
    122 C  nutrients 
    123 C  --------------------------------------------------------- 
    124 C 
    125       CALL p4zlim 
    126 C 
    127 C  Call production routine to compute phytoplankton growth rate 
    128 C  over the global ocean. Growth rates for each element is  
    129 C  computed (C, Si, Fe, Chl) 
    130 C  ------------------------------------------------------------ 
    131 C 
    132       CALL p4zprod 
    133 C 
    134 C  Call phytoplankton mortality routines. Mortality losses for  
    135 C  Each elements are computed (C, Fe, Si, Chl) 
    136 C  ----------------------------------------------------------- 
    137 C 
    138       CALL p4znano 
    139       CALL p4zdiat 
    140 C 
    141 C  Call zooplankton sources/sinks routines.  
    142 C  Each elements are computed (C, Fe, Si, Chl) 
    143 C  ----------------------------------------------------------- 
    144 C 
    145       CALL p4zmicro 
    146       CALL p4zmeso 
    147  
    148 C  
    149 C     Call subroutine for computation of remineralization 
    150 C     terms of organic matter+scavenging of Fe 
    151 C     ---------------------------------------------------- 
    152       CALL p4zrem 
    153 C      
    154 C     Determination of tracers concentration as a function of  
    155 C     biological sources and sinks 
    156 C     -------------------------------------------------------- 
    157 C      
    158       DO jk = 1,jpkm1 
    159         DO jj = 1,jpj 
    160           DO ji = 1,jpi 
    161 C      
    162 C     Evolution of PO4 
    163 C     ---------------- 
    164 C      
    165           trn(ji,jj,jk,jppo4) = trn(ji,jj,jk,jppo4) 
    166      &      -prorca(ji,jj,jk)-prorca2(ji,jj,jk) 
    167      &      +olimi(ji,jj,jk)+grarem(ji,jj,jk)*sigma1+denitr(ji,jj,jk) 
    168      &      +grarem2(ji,jj,jk)*sigma2 
    169 C 
    170 C     Evolution of NO3 and NH4 
    171 C     ------------------------ 
    172 C 
    173           trn(ji,jj,jk,jpno3) = trn(ji,jj,jk,jpno3) 
    174      &      -pronew(ji,jj,jk)-pronew2(ji,jj,jk)+onitr(ji,jj,jk) 
    175      &      -denitr(ji,jj,jk)*rdenit 
    176  
    177           trn(ji,jj,jk,jpnh4) = trn(ji,jj,jk,jpnh4) 
    178      &      -proreg(ji,jj,jk)-proreg2(ji,jj,jk)+olimi(ji,jj,jk) 
    179      &      +grarem(ji,jj,jk)*sigma1+grarem2(ji,jj,jk)*sigma2 
    180      &      -onitr(ji,jj,jk)+denitr(ji,jj,jk) 
    181  
    182           END DO 
    183         END DO 
    184       END DO 
    185  
    186       DO jk = 1,jpkm1 
    187         DO jj = 1,jpj 
    188           DO ji = 1,jpi 
    189  
    190 C     
    191 C     Evolution of Phytoplankton 
    192 C     -------------------------- 
    193 C      
    194           trn(ji,jj,jk,jpphy) = trn(ji,jj,jk,jpphy) 
    195      &      +prorca(ji,jj,jk)*(1.-excret)-tortp(ji,jj,jk) 
    196      &      -grazp(ji,jj,jk)-grazn(ji,jj,jk)-respp(ji,jj,jk) 
    197  
    198           trn(ji,jj,jk,jpnch) = trn(ji,jj,jk,jpnch) 
    199      &      +prorca6(ji,jj,jk)*(1.-excret)-tortnch(ji,jj,jk) 
    200      &      -grazpch(ji,jj,jk)-graznch(ji,jj,jk)-respnch(ji,jj,jk) 
    201 C 
    202 C     Evolution of Diatoms 
    203 C     ------------------ 
    204 C 
    205           trn(ji,jj,jk,jpdia) = trn(ji,jj,jk,jpdia) 
    206      &      +prorca2(ji,jj,jk)*(1.-excret2)-tortp2(ji,jj,jk) 
    207      &      -respp2(ji,jj,jk)-grazd(ji,jj,jk)-grazsd(ji,jj,jk) 
    208  
    209           trn(ji,jj,jk,jpdch) = trn(ji,jj,jk,jpdch) 
    210      &      +prorca7(ji,jj,jk)*(1.-excret2)-tortdch(ji,jj,jk) 
    211      &      -respdch(ji,jj,jk)-grazdch(ji,jj,jk)-grazsch(ji,jj,jk) 
    212           END DO 
    213         END DO 
    214       END DO 
    215  
    216       DO jk = 1,jpkm1 
    217         DO jj = 1,jpj 
    218           DO ji = 1,jpi 
    219 C     
    220 C     Evolution of Zooplankton 
    221 C     ------------------------ 
    222 C      
    223           trn(ji,jj,jk,jpzoo) = trn(ji,jj,jk,jpzoo) 
    224      &      +epsher*(grazp(ji,jj,jk)+grazm(ji,jj,jk)+grazsd(ji,jj,jk)) 
    225      &      -grazz(ji,jj,jk)-tortz(ji,jj,jk)-respz(ji,jj,jk) 
    226 C 
    227 C     Evolution of Mesozooplankton 
    228 C     ------------------------ 
    229 C 
    230           trn(ji,jj,jk,jpmes) = trn(ji,jj,jk,jpmes) 
    231      &      +epsher2*(grazd(ji,jj,jk)+grazz(ji,jj,jk)+grazn(ji,jj,jk) 
    232      &      +grazpoc(ji,jj,jk)+grazffe(ji,jj,jk))-tortz2(ji,jj,jk) 
    233      &      -respz2(ji,jj,jk) 
    234           END DO 
    235         END DO 
    236       END DO 
    237  
    238  
    239       DO jk = 1,jpkm1 
    240         DO jj = 1,jpj 
    241           DO ji = 1,jpi 
    242 C     
    243 C     Evolution of O2 
    244 C     --------------- 
    245 C      
    246          trn(ji,jj,jk,jpoxy) = trn(ji,jj,jk,jpoxy) 
    247      &     +o2ut*(proreg(ji,jj,jk)+proreg2(ji,jj,jk)-olimi(ji,jj,jk) 
    248      &     -grarem(ji,jj,jk)*sigma1-grarem2(ji,jj,jk)*sigma2) 
    249      &     +(o2ut+o2nit)*( pronew(ji,jj,jk)+pronew2(ji,jj,jk)) 
    250      &     -o2nit*onitr(ji,jj,jk) 
    251 C 
    252           END DO 
    253         END DO 
    254       END DO 
    255  
    256  
    257       DO jk = 1,jpkm1 
    258         DO jj = 1,jpj 
    259           DO ji = 1,jpi 
    260 C 
    261 C     Evolution of IRON 
    262 C     ----------------- 
    263 C 
    264           trn(ji,jj,jk,jpfer) = trn(ji,jj,jk,jpfer) 
    265      &      +(excret-1.)*prorca5(ji,jj,jk)-xaggdfe(ji,jj,jk) 
    266      &      +(excret2-1.)*prorca4(ji,jj,jk)-xbactfer(ji,jj,jk) 
    267      &      +grafer(ji,jj,jk)+grafer2(ji,jj,jk) 
    268      &      +ofer(ji,jj,jk)-xscave(ji,jj,jk) 
    269 C 
    270           END DO 
    271         END DO 
    272       END DO 
    273  
    274  
    275 #if defined key_kriest 
    276  
    277 #include "p4zbio.kriest.h" 
     234 
     235 
     236      DO jk = 1, jpkm1 
     237 
     238         ! Evolution of biogenic Silica 
     239         ! ---------------------------- 
     240         trn(:,:,jk,jpbsi) = trn(:,:,jk,jpbsi) + prorca3(:,:,jk) * ( 1.- excret2 ) - grazss(:,:,jk)   & 
     241            &                                  - tortds (:,:,jk) - respds(:,:,jk)  - grazs (:,:,jk) 
     242 
     243         ! Evolution of sinking biogenic silica 
     244         ! ------------------------------------ 
     245         trn(:,:,jk,jpdsi) = trn(:,:,jk,jpdsi) + tortds (:,:,jk) + respds(:,:,jk)  + grazs(:,:,jk)   & 
     246            &                                  - osil   (:,:,jk) + grazss(:,:,jk) 
     247 
     248         ! Evolution of biogenic diatom Iron 
     249         ! --------------------------------- 
     250         trn(:,:,jk,jpdfe) = trn(:,:,jk,jpdfe) + prorca4(:,:,jk) * ( 1.- excret2 ) - grazsf(:,:,jk)   & 
     251            &                                  - tortdf (:,:,jk) - respdf(:,:,jk)  - grazf (:,:,jk) 
     252 
     253         ! Evolution of biogenic nanophytoplankton Iron 
     254         ! -------------------------------------------- 
     255         trn(:,:,jk,jpnfe) = trn(:,:,jk,jpnfe) + prorca5(:,:,jk) * ( 1.- excret )  - graznf(:,:,jk)   & 
     256            &                                  - tortnf (:,:,jk) - respnf(:,:,jk)  - grazpf(:,:,jk) 
     257 
     258         ! Evolution of dissolved Silica 
     259         ! ----------------------------- 
     260         trn(:,:,jk,jpsil) = trn(:,:,jk,jpsil) - ( 1.- excret2 ) * prorca3(:,:,jk) + osil(:,:,jk) 
     261 
     262      END DO 
     263      
     264      ! Evolution of calcite and silicates as a function of the two tracers 
     265      ! -------------------------------------------------------------------      
     266      DO jk = 1, jpkm1 
     267         DO jj = 1, jpj 
     268            DO ji = 1, jpi 
     269 
     270               zprodt  = prorca(ji,jj,jk) + prorca2(ji,jj,jk) - olimi(ji,jj,jk) - grarem(ji,jj,jk) * sigma1   & 
     271                  &                       - grarem2(ji,jj,jk) * sigma2 - denitr(ji,jj,jk) 
     272               zprodca = pronew(ji,jj,jk) + pronew2(ji,jj,jk) - onitr(ji,jj,jk) + rdenit * denitr(ji,jj,jk) 
     273     
     274               ! potential production of calcite and biogenic silicate 
     275               ! ------------------------------------------------------      
     276               prcaca(ji,jj,jk) = zfracal(ji,jj,jk)   & 
     277                  &             * (  part * (  unass*grazp(ji,jj,jk) + unass2*grazn(ji,jj,jk)  )   & 
     278                  &                + tortp(ji,jj,jk) + respp(ji,jj,jk)  ) 
     279 
     280               ! Consumption of Total (12C)O2 
     281               ! ----------------------------      
     282               trn(ji,jj,jk,jpdic) = trn(ji,jj,jk,jpdic) - zprodt - prcaca(ji,jj,jk) 
     283 
     284               ! Consumption of alkalinity due to ca++ uptake and increase of 
     285               !  alkalinity due to nitrate consumption during organic soft tissue production 
     286               ! ---------------------------------------------------------   
     287               trn(ji,jj,jk,jptal) = trn(ji,jj,jk,jptal) + rno3 * zprodca - 2.* prcaca(ji,jj,jk) 
     288               ! 
     289            END DO 
     290         END DO 
     291      END DO 
     292 
     293 
     294      ! Production of calcite due to biological production 
     295      ! --------------------------------------------------    
     296      DO jk = 1, jpkm1 
     297         trn(:,:,jk,jpcal) = trn(:,:,jk,jpcal) + prcaca(:,:,jk) 
     298      END DO 
     299 
     300 
     301      ! Loop to test if tracers concentrations fall below 0. 
     302      ! ---------------------------------------------------- 
     303 
     304      znegtr(:,:,:) = 1.e0 
     305      DO jn = 1, jptra 
     306         DO jk = 1, jpk 
     307            DO jj = 1, jpj 
     308               DO ji = 1, jpi 
     309                  IF( trn(ji,jj,jk,jn) < 0.e0 )   znegtr(ji,jj,jk) = 0.e0 
     310               END DO 
     311            END DO 
     312         END DO 
     313      END DO 
     314      !                                ! where at least 1 tracer concentration becomes negative 
     315      !                                ! all tracer tendancy are set to zero (i.e. trn = trb) 
     316      DO jn = 1, jptra 
     317         trn(:,:,:,jn) = trb(:,:,:,jn) + znegtr(:,:,:) * ( trn(:,:,:,jn) - trb(:,:,:,jn) ) 
     318      END DO 
     319 
     320# if defined key_trc_dia3d 
     321!!gm potential bug  hard coded index on trc3d 
     322          trc3d(:,:,:, 4) = etot(:,:,:) 
     323          trc3d(:,:,:, 5) = prorca (:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     324          trc3d(:,:,:, 6) = prorca2(:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     325          trc3d(:,:,:, 7) = pronew (:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     326          trc3d(:,:,:, 8) = pronew2(:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     327          trc3d(:,:,:, 9) = prorca3(:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     328          trc3d(:,:,:,10) = prorca4(:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     329#  if ! defined key_kriest 
     330          trc3d(:,:,:,11) = prorca5(:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     331#  else 
     332          trc3d(:,:,:,11) = prcaca (:,:,:) * znegtr(:,:,:) * 1.e3 * rfact2r 
     333#  endif 
     334# endif 
     335      ! 
     336   END SUBROUTINE p4z_bio 
    278337 
    279338#else 
    280  
    281 #include "p4zbio.std.h" 
    282  
    283 #endif 
    284  
    285  
    286  
    287       DO jk = 1,jpkm1 
    288         DO jj = 1,jpj 
    289           DO ji = 1,jpi 
    290 C 
    291 C     Evolution of biogenic Silica 
    292 C     ---------------------------- 
    293 C 
    294           trn(ji,jj,jk,jpbsi) = trn(ji,jj,jk,jpbsi) 
    295      &      +prorca3(ji,jj,jk)*(1.-excret2)-grazss(ji,jj,jk) 
    296      &      -tortds(ji,jj,jk)-respds(ji,jj,jk)-grazs(ji,jj,jk) 
    297 C 
    298           END DO 
    299         END DO 
    300       END DO 
    301  
    302       DO jk = 1,jpkm1 
    303         DO jj = 1,jpj 
    304           DO ji = 1,jpi 
    305 C 
    306 C     Evolution of sinking biogenic silica 
    307 C     ------------------------------------ 
    308 C 
    309           trn(ji,jj,jk,jpdsi)=trn(ji,jj,jk,jpdsi) 
    310      &      +tortds(ji,jj,jk)+respds(ji,jj,jk)+grazs(ji,jj,jk) 
    311      &      -osil(ji,jj,jk)+grazss(ji,jj,jk) 
    312 C 
    313           END DO 
    314         END DO 
    315       END DO 
    316  
    317       DO jk = 1,jpkm1 
    318         DO jj = 1,jpj 
    319           DO ji = 1,jpi 
    320 C 
    321 C     Evolution of biogenic diatom Iron 
    322 C     --------------------------------- 
    323 C 
    324           trn(ji,jj,jk,jpdfe) = trn(ji,jj,jk,jpdfe) 
    325      &      +prorca4(ji,jj,jk)*(1.-excret2)-grazsf(ji,jj,jk) 
    326      &      -tortdf(ji,jj,jk)-respdf(ji,jj,jk)-grazf(ji,jj,jk) 
    327 C 
    328 C     Evolution of biogenic nanophytoplankton Iron 
    329 C     -------------------------------------------- 
    330 C 
    331           trn(ji,jj,jk,jpnfe) = trn(ji,jj,jk,jpnfe) 
    332      &      +prorca5(ji,jj,jk)*(1.-excret)-graznf(ji,jj,jk) 
    333      &      -tortnf(ji,jj,jk)-respnf(ji,jj,jk)-grazpf(ji,jj,jk) 
    334 C 
    335 C     Evolution of dissolved Silica 
    336 C     ----------------------------- 
    337 C 
    338           trn(ji,jj,jk,jpsil) = trn(ji,jj,jk,jpsil) 
    339      &      -(1.-excret2)*prorca3(ji,jj,jk)+osil(ji,jj,jk) 
    340 C 
    341           END DO 
    342         END DO 
    343       END DO 
    344 C      
    345 C     Evolution of calcite and silicates as a function of the two tracers 
    346 C     ------------------------------------------------------------------- 
    347 C      
    348       DO  jk = 1,jpkm1 
    349         DO  jj = 1,jpj 
    350           DO  ji = 1,jpi 
    351 C 
    352           prodt = prorca(ji,jj,jk)+prorca2(ji,jj,jk) 
    353      &      -olimi(ji,jj,jk)-grarem(ji,jj,jk)*sigma1 
    354      &      -grarem2(ji,jj,jk)*sigma2-denitr(ji,jj,jk) 
    355  
    356           prodca = pronew(ji,jj,jk)+pronew2(ji,jj,jk) 
    357      &      -onitr(ji,jj,jk)+rdenit*denitr(ji,jj,jk) 
    358 C      
    359 C     potential production of calcite and biogenic silicate 
    360 C     ------------------------------------------------------ 
    361 C      
    362           prcaca(ji,jj,jk)= 
    363      &      zfracal(ji,jj,jk)*(part*(unass*grazp(ji,jj,jk)+ 
    364      &      unass2*grazn(ji,jj,jk))+tortp(ji,jj,jk)+respp(ji,jj,jk)) 
    365 C      
    366 C     Consumption of Total (12C)O2 
    367 C     ---------------------------- 
    368 C      
    369           trn(ji,jj,jk,jpdic) = trn(ji,jj,jk,jpdic) 
    370      &      -prodt-prcaca(ji,jj,jk) 
    371 C      
    372 C     Consumption of alkalinity due to ca++ uptake and increase  
    373 C     of alkalinity due to nitrate consumption during organic  
    374 C     soft tissue production 
    375 C     --------------------------------------------------------- 
    376 C      
    377           trn(ji,jj,jk,jptal) = trn(ji,jj,jk,jptal) 
    378      &      +rno3*prodca-2.*prcaca(ji,jj,jk) 
    379           END DO 
    380         END DO 
    381       END DO 
    382 C 
    383       DO  jk = 1,jpkm1 
    384         DO  jj = 1,jpj 
    385           DO  ji = 1,jpi 
    386 C 
    387 C     Production of calcite due to biological production 
    388 C     -------------------------------------------------- 
    389 C      
    390            trn(ji,jj,jk,jpcal) = trn(ji,jj,jk,jpcal) 
    391      &        +prcaca(ji,jj,jk) 
    392           END DO 
    393         END DO 
    394       ENDDO 
    395 C 
    396 C 
    397 C     Loop to test if tracers concentrations fall below 0. 
    398 C     ---------------------------------------------------- 
    399 C 
    400 C 
    401       znegtr(:,:,:) = 1. 
    402 C 
    403       DO jn = 1,jptra 
    404         DO jk = 1,jpk 
    405           DO jj = 1,jpj 
    406             DO ji = 1,jpi 
    407               if (trn(ji,jj,jk,jn).lt.0.) then 
    408                znegtr(ji,jj,jk)=0. 
    409               endif 
    410             END DO 
    411           END DO 
    412         END DO 
    413       END DO 
    414 C 
    415       DO jn = 1,jptra 
    416          trn(:,:,:,jn) = trb(:,:,:,jn)+ 
    417      &     znegtr(:,:,:)*(trn(:,:,:,jn)-trb(:,:,:,jn)) 
    418       END DO 
    419 C 
    420 #    if defined key_trc_dia3d 
    421           trc3d(:,:,:,4)=etot(:,:,:) 
    422           trc3d(:,:,:,5)=prorca(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    423           trc3d(:,:,:,6)=prorca2(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    424           trc3d(:,:,:,7)=pronew(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    425           trc3d(:,:,:,8)=pronew2(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    426           trc3d(:,:,:,9)=prorca3(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    427           trc3d(:,:,:,10)=prorca4(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    428 #if ! defined key_kriest 
    429           trc3d(:,:,:,11)=prorca5(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    430 #else 
    431           trc3d(:,:,:,11)=prcaca(:,:,:)*znegtr(:,:,:)*1e3*rfact2r 
    432 #endif 
    433 #    endif 
    434 C      
    435 #endif 
    436 C      
    437       RETURN 
    438       END 
     339   !!====================================================================== 
     340   !!  Dummy module :                                   No PISCES bio-model 
     341   !!====================================================================== 
     342CONTAINS 
     343   SUBROUTINE p4z_bio                         ! Empty routine 
     344   END SUBROUTINE p4z_bio 
     345#endif  
     346 
     347   !!====================================================================== 
     348END MODULE  p4zbio 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zbio_kriest.h90

    r774 r775  
    11 
     2      !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
     3      !CC p4zbio : PISCES MODEL  - Kriest parameterization 
     4      !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
    25 
    3 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
    4 CCC p4zbio : PISCES MODEL  - Kriest parameterization 
    5 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
     6      DO jk = 1, jpkm1 
     7         DO jj = 1, jpj 
     8            DO ji = 1, jpi 
     9     
     10               !     Evolution of DOC 
     11               !     ----------------      
     12               trn(ji,jj,jk,jpdoc) = trn(ji,jj,jk,jpdoc) + orem(ji,jj,jk)                                  & 
     13                  &                                      + excret2 * prorca2(ji,jj,jk)                     & 
     14                  &                                      + excret  * prorca (ji,jj,jk) - olimi(ji,jj,jk)   & 
     15                  &                                      - denitr(ji,jj,jk)                                & 
     16                  &                                      + grarem (ji,jj,jk) * (1.-sigma1)                 & 
     17                  &                                      + grarem2(ji,jj,jk) * (1.-sigma2) - xaggdoc(ji,jj,jk) 
     18      
     19               !     Evolution of Detritus 
     20               !     --------------------- 
     21               znumpoc = trn(ji,jj,jk,jpnum) / ( trn(ji,jj,jk,jppoc) + rtrn ) 
     22               znumdoc = znumpoc 
    623 
    7       DO jk = 1,jpkm1 
    8         DO jj = 1,jpj 
    9           DO ji = 1,jpi 
    10 C     
    11 C     Evolution of DOC 
    12 C     ---------------- 
    13 C      
    14           trn(ji,jj,jk,jpdoc) = trn(ji,jj,jk,jpdoc) 
    15      &      +orem(ji,jj,jk)+excret2*prorca2(ji,jj,jk) 
    16      &      +excret*prorca(ji,jj,jk)-olimi(ji,jj,jk)-denitr(ji,jj,jk) 
    17      &      +grarem(ji,jj,jk)*(1.-sigma1)+grarem2(ji,jj,jk) 
    18      &      *(1.-sigma2)-xaggdoc(ji,jj,jk) 
    19           END DO 
    20         END DO 
     24               trn(ji,jj,jk,jppoc) = trn(ji,jj,jk,jppoc) - grazpoc(ji,jj,jk)                       & 
     25                  &                                      + grapoc (ji,jj,jk) + grapoc2(ji,jj,jk)   & 
     26                  &                                      - grazm  (ji,jj,jk) + tortz2 (ji,jj,jk)   & 
     27                  &                                      + respz  (ji,jj,jk) + respz2 (ji,jj,jk)   & 
     28                  &                                      + respp  (ji,jj,jk) + respp2 (ji,jj,jk)   & 
     29                  &                                      + tortp2 (ji,jj,jk) + tortz  (ji,jj,jk)   & 
     30                  &                                      + tortp  (ji,jj,jk) - orem   (ji,jj,jk)   & 
     31                  &                                      + xaggdoc(ji,jj,jk) - grazffe(ji,jj,jk) 
     32 
     33               !     Evolution of number of aggregates 
     34               !     --------------------------------- 
     35               trn(ji,jj,jk,jpnum) = trn(ji,jj,jk,jpnum) - xagg(ji,jj,jk)                                           & 
     36                  &                                      - ( orem(ji,jj,jk) + grazpoc(ji,jj,jk) ) * znumpoc         & 
     37                  &                                      + ( tortp(ji,jj,jk) ) * xkr_nnano                          & 
     38                  &                                      + ( tortp2(ji,jj,jk) + respp(ji,jj,jk) + tortz(ji,jj,jk)   & 
     39                  &                                        + grapoc(ji,jj,jk) - grazm(ji,jj,jk)                     & 
     40                  &                                        + respz(ji,jj,jk) ) * xkr_ndiat                          & 
     41                  &                                      + ( grapoc2(ji,jj,jk) + tortz2(ji,jj,jk)                   & 
     42                  &                                        + respz2 (ji,jj,jk) ) * xkr_nmeso                        & 
     43                  &                                      + respp2(ji,jj,jk) * xkr_naggr                             & 
     44                  &                                      + xaggdoc(ji,jj,jk) * znumdoc                              & 
     45                  &                                      - grazffe(ji,jj,jk) * znumpoc * wsbio4(ji,jj,jk)           & 
     46                  &                                      / ( wsbio3(ji,jj,jk) + rtrn ) 
     47 
     48               trn(ji,jj,jk,jpnum) = MAX( trn(ji,jj,jk,jpnum), trn(ji,jj,jk,jppoc) / xkr_massp / xnumm(jk) ) 
     49 
     50               trn(ji,jj,jk,jpnum) = MIN( trn(ji,jj,jk,jpnum), trn(ji,jj,jk,jppoc) / xkr_massp / 1.1       ) 
     51 
     52               !     Evolution of biogenic Iron 
     53               !     -------------------------- 
     54               trn(ji,jj,jk,jpsfe) = trn(ji,jj,jk,jpsfe) + unass * ( grazpf(ji,jj,jk) + grazsf(ji,jj,jk) )   & 
     55                  &                - ( 1.- unass2 ) * grazpof(ji,jj,jk) - ( 1.- unass ) * grazmf(ji,jj,jk)   & 
     56                  &                - ( 1.- unass2 ) * grazfff(ji,jj,jk) +       unass2  * ( graznf(ji,jj,jk)   & 
     57                  &                + grazf(ji,jj,jk) + ferat3 * grazz(ji,jj,jk) ) + ferat3                   & 
     58                  &                * (tortz2(ji,jj,jk)+respz2(ji,jj,jk)+tortz(ji,jj,jk)                      & 
     59                  &                + respz(ji,jj,jk) ) - ofer(ji,jj,jk) + ( respnf(ji,jj,jk)                 & 
     60                  &                + tortnf(ji,jj,jk) ) + tortdf(ji,jj,jk) + respdf(ji,jj,jk)                & 
     61                  &                + xbactfer(ji,jj,jk) + xscave(ji,jj,jk) * zdenom1(ji,jj,jk) 
     62            END DO 
     63         END DO 
    2164      END DO 
    22  
    23  
    24       DO jk = 1,jpkm1 
    25         DO jj = 1,jpj 
    26           DO ji = 1,jpi 
    27 C      
    28 C     Evolution of Detritus 
    29 C     --------------------- 
    30 C   
    31             znumpoc=trn(ji,jj,jk,jpnum)/(trn(ji,jj,jk,jppoc)+rtrn) 
    32             znumdoc=znumpoc 
    33  
    34             trn(ji,jj,jk,jppoc) = trn(ji,jj,jk,jppoc) 
    35      &          -grazpoc(ji,jj,jk) 
    36      &          +grapoc(ji,jj,jk)+grapoc2(ji,jj,jk) 
    37      &          -grazm(ji,jj,jk)+tortz2(ji,jj,jk) 
    38      &          +respz(ji,jj,jk)+respz2(ji,jj,jk) 
    39      &          +respp(ji,jj,jk)+respp2(ji,jj,jk) 
    40      &          +tortp2(ji,jj,jk)+tortz(ji,jj,jk) 
    41      &          +tortp(ji,jj,jk)-orem(ji,jj,jk) 
    42      &          +xaggdoc(ji,jj,jk)-grazffe(ji,jj,jk) 
    43 C     
    44 C     Evolution of number of aggregates 
    45 C     --------------------------------- 
    46 C 
    47             trn(ji,jj,jk,jpnum) = trn(ji,jj,jk,jpnum) 
    48      &          -xagg(ji,jj,jk)-(orem(ji,jj,jk) 
    49      &          +grazpoc(ji,jj,jk))*znumpoc 
    50      &          +(tortp(ji,jj,jk))*xkr_nnano 
    51      &          +(tortp2(ji,jj,jk)+respp(ji,jj,jk)+tortz(ji,jj,jk) 
    52      &          +grapoc(ji,jj,jk)-grazm(ji,jj,jk) 
    53      &          +respz(ji,jj,jk))*xkr_ndiat 
    54      &          +(grapoc2(ji,jj,jk)+tortz2(ji,jj,jk) 
    55      &          +respz2(ji,jj,jk))*xkr_nmeso 
    56      &          +respp2(ji,jj,jk)*xkr_naggr 
    57      &          +xaggdoc(ji,jj,jk)*znumdoc 
    58      &          -grazffe(ji,jj,jk)*znumpoc*wsbio4(ji,jj,jk) 
    59      &          /(wsbio3(ji,jj,jk)+rtrn) 
    60 C 
    61             trn(ji,jj,jk,jpnum) = max(trn(ji,jj,jk,jpnum), 
    62      &          trn(ji,jj,jk,jppoc)/xkr_massp/xnumm(jk)) 
    63 C 
    64             trn(ji,jj,jk,jpnum) = min(trn(ji,jj,jk,jpnum), 
    65      &          trn(ji,jj,jk,jppoc)/xkr_massp/1.1) 
    66 C 
    67  
    68           END DO 
    69         END DO 
    70       END DO 
    71  
    72  
    73  
    74       DO jk = 1,jpkm1 
    75         DO jj = 1,jpj 
    76           DO ji = 1,jpi 
    77 C 
    78 C     Evolution of biogenic Iron 
    79 C     -------------------------- 
    80 C 
    81           trn(ji,jj,jk,jpsfe) = trn(ji,jj,jk,jpsfe) 
    82      &     +unass*(grazpf(ji,jj,jk)+grazsf(ji,jj,jk)) 
    83      &     -(1.-unass2)*grazpof(ji,jj,jk)-(1.-unass)*grazmf(ji,jj,jk) 
    84      &     -(1.-unass2)*grazfff(ji,jj,jk)+unass2*(graznf(ji,jj,jk) 
    85      &     +grazf(ji,jj,jk)+ferat3*grazz(ji,jj,jk))+ferat3 
    86      &     *(tortz2(ji,jj,jk)+respz2(ji,jj,jk)+tortz(ji,jj,jk) 
    87      &     +respz(ji,jj,jk))-ofer(ji,jj,jk)+(respnf(ji,jj,jk) 
    88      &     +tortnf(ji,jj,jk))+tortdf(ji,jj,jk)+respdf(ji,jj,jk) 
    89      &     +xbactfer(ji,jj,jk)+xscave(ji,jj,jk)*zdenom1(ji,jj,jk) 
    90           END DO 
    91         END DO 
    92       END DO 
    93  

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zbio_std.h90

    r774 r775  
    1 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
    2 CCC p4zbio : PISCES MODEL  - Standard parameterization 
    3 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
     1      !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
     2      !CC p4zbio : PISCES MODEL  - Standard parameterization 
     3      !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
    44 
    5       DO jk = 1,jpkm1 
    6         DO jj = 1,jpj 
    7           DO ji = 1,jpi 
    8 C     
    9 C     Evolution of DOC 
    10 C     ---------------- 
    11 C      
    12           trn(ji,jj,jk,jpdoc) = trn(ji,jj,jk,jpdoc) 
    13      &      +orem(ji,jj,jk)+excret2*prorca2(ji,jj,jk) 
    14      &      +excret*prorca(ji,jj,jk)-olimi(ji,jj,jk)-denitr(ji,jj,jk) 
    15      &      +grarem(ji,jj,jk)*(1.-sigma1)+grarem2(ji,jj,jk) 
    16      &      *(1.-sigma2)-xaggdoc(ji,jj,jk)-xaggdoc2(ji,jj,jk) 
    17           END DO 
    18         END DO 
     5      DO jk = 1, jpkm1 
     6     
     7         !     Evolution of DOC 
     8         !     ----------------      
     9         trn(:,:,jk,jpdoc) = trn(:,:,jk,jpdoc) + orem(:,:,jk) + excret2 * prorca2(:,:,jk)                       & 
     10            &                                  + excret * prorca(:,:,jk) - olimi(:,:,jk) - denitr(:,:,jk)       & 
     11            &                                  + grarem(:,:,jk) * (1.-sigma1) + grarem2(:,:,jk) * (1.-sigma2)   & 
     12            &                                  - xaggdoc(:,:,jk) - xaggdoc2(:,:,jk) 
     13      
     14         !     Evolution of Detritus 
     15         !     --------------------- 
     16         trn(:,:,jk,jppoc) = trn(:,:,jk,jppoc) - grazpoc(:,:,jk) + grapoc(:,:,jk) - grazm  (:,:,jk)                 & 
     17            &                                  + respz  (:,:,jk) - xagg  (:,:,jk) + xaggdoc(:,:,jk)                 & 
     18            &                                  + ( 1.-0.5 * zfracal(:,:,jk) ) * ( tortp(:,:,jk) + respp(:,:,jk) )   & 
     19            &                                  +      0.5 * tortp2 (:,:,jk)                                         & 
     20            &                                  + orem2(:,:,jk) + tortz(:,:,jk) - orem(:,:,jk) 
     21 
     22         !     Evolution of rapid Detritus 
     23         !     --------------------------- 
     24         trn(:,:,jk,jpgoc) = trn(:,:,jk,jpgoc) + grapoc2(:,:,jk) + respp2(:,:,jk) + xagg (:,:,jk)            & 
     25            &                                  + tortz2 (:,:,jk) + respz2(:,:,jk) - orem2(:,:,jk)            & 
     26            &                                  + 0.5*zfracal(:,:,jk)*(respp(:,:,jk)+tortp(:,:,jk))           & 
     27            &                                  + 0.5*tortp2(:,:,jk)+xaggdoc2(:,:,jk)-grazffe(:,:,jk) 
     28 
     29         !     Evolution of small biogenic Iron 
     30         !     -------------------------------- 
     31         trn(:,:,jk,jpsfe) = trn(:,:,jk,jpsfe) + unass * ( grazpf(:,:,jk) + grazsf(:,:,jk) )           & 
     32            &                                  - grazpof(:,:,jk) - ( 1.- unass ) * grazmf(:,:,jk)      & 
     33            &                                  + ( 1.- 0.5 * zfracal(:,:,jk) ) * ( tortnf(:,:,jk)      & 
     34            &                                  + respnf(:,:,jk) ) + 0.5 * tortdf(:,:,jk) + ferat3 *    & 
     35            &                                    ( tortz(:,:,jk) + respz(:,:,jk) ) - ofer(:,:,jk)      & 
     36            &                                  + ofer2(:,:,jk) - xaggfe(:,:,jk)                        & 
     37            &                                  + xscave(:,:,jk) * zdenom1(:,:,jk) 
     38 
     39         !     Evolution of big biogenic Iron 
     40         !     ------------------------------ 
     41         trn(:,:,jk,jpbfe) = trn(:,:,jk,jpbfe) + unass2 * ( graznf (:,:,jk) + grazf(:,:,jk) + grazfff(:,:,jk)   & 
     42            &                                             + grazpof(:,:,jk) + ferat3 * grazz(:,:,jk) )          & 
     43            &                                  + ferat3 * ( tortz2 (:,:,jk) + respz2(:,:,jk) )                  & 
     44            &                                  - ofer2(:,:,jk)                                                  & 
     45            &                                  + 0.5 * zfracal(:,:,jk) * ( respnf(:,:,jk) + tortnf(:,:,jk) )    & 
     46            &                                  + 0.5 * tortdf (:,:,jk) + respdf(:,:,jk) + xaggfe(:,:,jk)        & 
     47            &                                  + xbactfer(:,:,jk) - grazfff(:,:,jk) + xscave(:,:,jk) * zdenom2(:,:,jk) 
     48         ! 
    1949      END DO 
    20  
    21       DO jk = 1,jpkm1 
    22         DO jj = 1,jpj 
    23           DO ji = 1,jpi 
    24 C      
    25 C     Evolution of Detritus 
    26 C     --------------------- 
    27 C      
    28           trn(ji,jj,jk,jppoc) = trn(ji,jj,jk,jppoc) 
    29      &     -grazpoc(ji,jj,jk)+grapoc(ji,jj,jk)-grazm(ji,jj,jk) 
    30      &     +respz(ji,jj,jk)-xagg(ji,jj,jk)+xaggdoc(ji,jj,jk) 
    31      &     +(1.-0.5*zfracal(ji,jj,jk))*(tortp(ji,jj,jk) 
    32      &     +respp(ji,jj,jk))+0.5*tortp2(ji,jj,jk) 
    33      &     +orem2(ji,jj,jk)+tortz(ji,jj,jk)-orem(ji,jj,jk) 
    34 C     
    35 C     Evolution of rapid Detritus 
    36 C     --------------------- 
    37 C     
    38           trn(ji,jj,jk,jpgoc) = trn(ji,jj,jk,jpgoc) 
    39      &     +grapoc2(ji,jj,jk)+respp2(ji,jj,jk)+xagg(ji,jj,jk) 
    40      &     +tortz2(ji,jj,jk)+respz2(ji,jj,jk)-orem2(ji,jj,jk) 
    41      &     +0.5*zfracal(ji,jj,jk)*(respp(ji,jj,jk)+tortp(ji,jj,jk)) 
    42      &     +0.5*tortp2(ji,jj,jk)+xaggdoc2(ji,jj,jk)-grazffe(ji,jj,jk) 
    43 C 
    44           END DO 
    45         END DO 
    46       END DO 
    47  
    48  
    49  
    50       DO jk = 1,jpkm1 
    51         DO jj = 1,jpj 
    52           DO ji = 1,jpi 
    53 C 
    54 C     Evolution of small biogenic Iron 
    55 C     -------------------------- 
    56 C 
    57           trn(ji,jj,jk,jpsfe) = trn(ji,jj,jk,jpsfe) 
    58      &     +unass*(grazpf(ji,jj,jk)+grazsf(ji,jj,jk)) 
    59      &     -grazpof(ji,jj,jk)-(1.-unass)*grazmf(ji,jj,jk) 
    60      &     +(1.-0.5*zfracal(ji,jj,jk))*(tortnf(ji,jj,jk) 
    61      &     +respnf(ji,jj,jk))+0.5*tortdf(ji,jj,jk)+ferat3* 
    62      &     (tortz(ji,jj,jk)+respz(ji,jj,jk))-ofer(ji,jj,jk) 
    63      &     +ofer2(ji,jj,jk)-xaggfe(ji,jj,jk) 
    64      &     +xscave(ji,jj,jk)*zdenom1(ji,jj,jk) 
    65 C 
    66 C     Evolution of big biogenic Iron 
    67 C     -------------------------- 
    68 C 
    69           trn(ji,jj,jk,jpbfe) = trn(ji,jj,jk,jpbfe) 
    70      &     +unass2*(graznf(ji,jj,jk)+grazf(ji,jj,jk)+grazfff(ji,jj,jk) 
    71      &     +grazpof(ji,jj,jk)+ferat3*grazz(ji,jj,jk))+ferat3* 
    72      &     (tortz2(ji,jj,jk)+respz2(ji,jj,jk))-ofer2(ji,jj,jk) 
    73      &     +0.5*zfracal(ji,jj,jk)*(respnf(ji,jj,jk)+tortnf(ji,jj,jk)) 
    74      &     +0.5*tortdf(ji,jj,jk)+respdf(ji,jj,jk)+xaggfe(ji,jj,jk) 
    75      &     +xbactfer(ji,jj,jk)-grazfff(ji,jj,jk)+xscave(ji,jj,jk) 
    76      &     *zdenom2(ji,jj,jk) 
    77           END DO 
    78         END DO 
    79       END DO 
    80  

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zche.F90

    r774 r775  
    1  
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zche 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC          ROUTINE p4zche : PISCES MODEL 
    12 CCC          ***************************** 
    13 CCC 
    14 CCC     PURPOSE. 
    15 CCC     -------- 
    16 CCC          *P4ZCHE* : Sea water chemistry computed following OCMIP protocol 
    17 CCC 
    18 CCC 
    19 CC     EXTERNALS. 
    20 CC     ---------- 
    21 CC          rhop 
    22 CC 
    23 CC   MODIFICATIONS: 
    24 CC   -------------- 
    25 CC      original :      1988 E. Maier-Reimer 
    26 CC      additions :     1998 O. Aumont 
    27 CC      modifications : 1999 C. Le Quere 
    28 CC      modifications : 2004 O. Aumont 
    29 CC      modifications : 2006 R. Gangsto 
    30 CC---------------------------------------------------------------------- 
    31 CC parameters and commons 
    32 CC ====================== 
    33 CDIR$ nolist 
    34       USE oce_trc 
    35       USE trp_trc 
    36       USE sms 
    37       IMPLICIT NONE 
     1MODULE p4zche 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zche  *** 
     4   !! TOP :   PISCES Sea water chemistry computed following OCMIP protocol 
     5   !!====================================================================== 
     6   !! History :    -   !  1988     (E. Maier-Reimer)  Original code 
     7   !!              -   !  1998     (O. Aumont)  addition 
     8   !!              -   !  1999     (C. Le Quere)  modification 
     9   !!             1.0  !  2004     (O. Aumont)  modification 
     10   !!              -   !  2006     (R. Gangsto)  modification 
     11   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     12   !!---------------------------------------------------------------------- 
     13#if defined key_pisces 
     14   !!---------------------------------------------------------------------- 
     15   !!   'key_pisces'                                       PISCES bio-model 
     16   !!---------------------------------------------------------------------- 
     17   !!   p4z_che        :  Sea water chemistry computed following OCMIP protocol 
     18   !!---------------------------------------------------------------------- 
     19   USE oce_trc         ! 
     20   USE trp_trc         ! 
     21   USE sms             !  
     22 
     23   IMPLICIT NONE 
     24   PRIVATE 
     25 
     26   PUBLIC   p4z_che    ! called in p4zprg.F90 
     27 
     28   !!* Substitution 
    3829#include "domzgr_substitute.h90" 
    39 CDIR$ list 
    40 CC---------------------------------------------------------------------- 
    41 CC local declarations 
    42 CC ================== 
    43 C 
    44       INTEGER ji, jj, jk 
    45       REAL tkel, sal,  qtt, zbuf1, zbuf2 
    46       REAL pres, tc, cl, cpexp, cek0, oxy, cpexp2 
    47       REAL zsqrt, ztr, zlogt, cek1 
    48       REAL zqtt, qtt2, sal15, zis, zis2, zisqrt 
    49       REAL ckb, ck1, ck2, ckw, ak1, ak2, akb, aksp0, akw 
    50       REAL ckp1, ckp2, ckp3, cksi, akp1, akp2, akp3, aksi 
    51       REAL st, ft, cks, ckf, aks, akf, aksp1 
    52  
    53 C 
    54 C* 1. CHEMICAL CONSTANTS - SURFACE LAYER 
    55 C --------------------------------------- 
    56 C 
    57       DO jj = 1,jpj 
    58         DO ji = 1,jpi 
    59 C 
    60 C* 1.1 SET ABSOLUTE TEMPERATURE 
    61 C ------------------------------ 
    62 C 
    63           tkel = tn(ji,jj,1)+273.16 
    64           qtt = tkel*0.01 
    65           qtt2=qtt*qtt 
    66           sal = sn(ji,jj,1) + (1.-tmask(ji,jj,1))*35. 
    67           zqtt=log(qtt) 
    68 C 
    69 C* 1.2 LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 
    70 C      AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
    71 C ------------------------------------------------------- 
    72 C 
    73           cek0 = c00+c01/qtt+c02*zqtt+sal*(c03+c04*qtt+c05*qtt2) 
    74           cek1 = ca0+ca1/qtt+ca2*zqtt+ca3*qtt2+sal*(ca4 
    75      &      +ca5*qtt+ca6*qtt2) 
    76 C 
    77 C* 1.3 LN(K0) OF SOLUBILITY OF O2 and N2 (EQ. 4, WEISS, 1970) 
    78 C ------------------------------------------------------------ 
    79 C 
    80           oxy = ox0+ox1/qtt+ox2*zqtt+sal*(ox3+ox4*qtt+ox5*qtt2) 
    81 C 
    82 C* 1.4 SET SOLUBILITIES OF O2 AND CO2 
    83 C ----------------------------------- 
    84 C 
    85           chemc(ji,jj,1) = exp(cek0)*1.E-6*rhop(ji,jj,1)/1000. 
    86           chemc(ji,jj,2) = exp(oxy)*oxyco 
    87           chemc(ji,jj,3) = exp(cek1)*1.E-6*rhop(ji,jj,1)/1000. 
    88 C 
    89         ENDDO 
     30   !!---------------------------------------------------------------------- 
     31   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     32   !! $Header:$  
     33   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     34   !!---------------------------------------------------------------------- 
     35 
     36CONTAINS 
     37 
     38   SUBROUTINE p4z_che 
     39      !!--------------------------------------------------------------------- 
     40      !!                     ***  ROUTINE p4z_che  *** 
     41      !! 
     42      !! ** Purpose :   Sea water chemistry computed following OCMIP protocol 
     43      !! 
     44      !! ** Method  : - ... 
     45      !!--------------------------------------------------------------------- 
     46      INTEGER  ::   ji, jj, jk 
     47      REAL(wp) ::   ztkel, zsal , zqtt  , zbuf1 , zbuf2 
     48      REAL(wp) ::   zpres, ztc  , zcl   , zcpexp, zcek0, zoxy  , zcpexp2 
     49      REAL(wp) ::   zsqrt, ztr  , zlogt , zcek1 
     50      REAL(wp) ::   zlqtt, zqtt2, zsal15, zis   , zis2 , zisqrt 
     51      REAL(wp) ::   zckb , zck1 , zck2  , zckw  , zak1 , zak2  , zakb , zaksp0, zakw 
     52      REAL(wp) ::   zckp1, zckp2, zckp3 , zcksi , zakp1, zakp2 , zakp3, zaksi 
     53      REAL(wp) ::   zst  , zft  , zcks  , zckf  , zaks , zakf  , zaksp1 
     54      !!--------------------------------------------------------------------- 
     55 
     56      ! CHEMICAL CONSTANTS - SURFACE LAYER 
     57      ! ---------------------------------- 
     58 
     59      DO jj = 1, jpj 
     60         DO ji = 1, jpi 
     61 
     62            !                             ! SET ABSOLUTE TEMPERATURE 
     63            ztkel = tn(ji,jj,1) + 273.16 
     64            zqtt  = ztkel * 0.01 
     65            zqtt2 = zqtt * zqtt 
     66            zsal  = sn(ji,jj,1) + (1.- tmask(ji,jj,1) ) * 35. 
     67            zlqtt = LOG( zqtt ) 
     68 
     69            !                             ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 
     70            !                             !     AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
     71            zcek0 = c00 + c01 / zqtt + c02 * zlqtt + zsal * ( c03 + c04 * zqtt + c05 * zqtt2 ) 
     72            zcek1 = ca0 + ca1 / zqtt + ca2 * zlqtt + ca3 * zqtt2 + zsal*( ca4 + ca5 * zqtt + ca6 * zqtt2 ) 
     73 
     74            !                             ! LN(K0) OF SOLUBILITY OF O2 and N2 (EQ. 4, WEISS, 1970) 
     75            zoxy  = ox0 + ox1 / zqtt + ox2 * zlqtt + zsal * ( ox3 + ox4 * zqtt + ox5 * zqtt2 ) 
     76 
     77            !                             ! SET SOLUBILITIES OF O2 AND CO2 
     78            chemc(ji,jj,1) = EXP( zcek0 ) * 1.e-6 * rhop(ji,jj,1) / 1000. 
     79            chemc(ji,jj,2) = EXP( zoxy  ) * oxyco 
     80            chemc(ji,jj,3) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. 
     81 
     82         END DO 
    9083      END DO 
    91 C 
    92 C* 2 CHEMICAL CONSTANTS - DEEP OCEAN 
    93 C ------------------------------------- 
    94 C 
    95       DO jk = 1,jpk 
    96         DO jj = 1,jpj 
    97           DO ji = 1,jpi 
    98 C 
    99 C* 2.1 SET PRESSION 
    100 C ----------------- 
    101 C 
    102             pres = 1.025e-1*fsdept(ji,jj,jk) 
    103 C 
    104 C* 2.2 SET ABSOLUTE TEMPERATURE 
    105 C ------------------------------ 
    106 C 
    107             tkel   = tn(ji,jj,jk)+273.16 
    108             qtt    = tkel*0.01 
    109             sal    = sn(ji,jj,jk) + (1.-tmask(ji,jj,jk))*35. 
    110             zsqrt  = sqrt(sal) 
    111             sal15  = zsqrt*sal 
    112             zlogt  = log(tkel) 
    113             ztr    = 1./tkel 
    114             zis    = 19.924*sal/(1000.-1.005*sal) 
    115             zis2   = zis*zis 
    116             zisqrt = sqrt(zis) 
    117             tc = tn(ji,jj,jk) + (1.-tmask(ji,jj,jk))*20. 
    118 C 
    119 C* 2.3 CHLORINITY (WOOSTER ET AL., 1969) 
    120 C --------------------------------------- 
    121 C 
    122             cl = sal*salchl 
    123 C 
    124 C* 2.4 TOTAL SULFATE CONCENTR. [MOLES/kg soln] 
    125 C -------------------------------------------- 
    126 C 
    127             st = st1*cl*st2 
    128 C 
    129 C* 2.5 TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] 
    130 C --------------------------------------------- 
    131 C 
    132             ft = ft1*cl*ft2 
    133 C 
    134 C* 2.6 DISSOCIATION CONSTANT FOR SULFATES 
    135 C on free H scale (Dickson 1990) 
    136 C ------------------------------------------------------- 
    137 C 
    138             cks=exp(ks1*ztr+ks0+ks2*zlogt+(ks3*ztr+ks4+ks5*zlogt) 
    139      &      *zisqrt+(ks6*ztr+ks7+ks8*zlogt)*zis+ks9*ztr*zis 
    140      &      *zisqrt+ks10*ztr*zis2+log(ks11+ks12*sal)) 
    141 C 
    142 C* 2.7 DISSOCIATION CONSTANT FOR FLUORIDES 
    143 C on free H scale (Dickson and Riley 79) 
    144 C ------------------------------------------------------- 
    145 C 
    146             ckf=exp(kf1*ztr+kf0+kf2*zisqrt+log(kf3+kf4*sal)) 
    147  
    148 C 
    149 C* 2.4 DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 
    150 C ------------------------------------------------------- 
    151 C 
    152             ckb = (cb0+cb1*zsqrt+cb2*sal+cb3*sal15+cb4*sal*sal)*ztr 
    153      &          +(cb5+cb6*zsqrt+cb7*sal)+ 
    154      &          (cb8+cb9*zsqrt+cb10*sal)*zlogt+cb11*zsqrt*tkel 
    155      &          +log((1.+st/cks+ft/ckf)/(1.+st/cks)) 
    156             ck1 = c10*ztr+c11+c12*zlogt+c13*sal+c14*sal**2 
    157             ck2 = c20*ztr+c21+c22*sal+c23*sal**2 
    158 C 
    159 C* 2.5 PKW (H2O) (DICKSON AND RILEY, 1979) 
    160 C ----------------------------------------- 
    161 C 
    162             ckw = cw0*ztr+cw1+cw2*zlogt+(cw3*ztr+cw4+cw5*zlogt)* 
    163      &          zsqrt+cw6*sal 
    164  
    165 C 
    166 C 
    167 C* 2.10 DISSOCIATION CONSTANT FOR PHOSPHATE AND SILICATE (seawater scale) 
    168 C  --------------------------------------------------------------------- 
    169 C 
    170             ckp1 = cp10+cp11*ztr+cp12*zlogt+zsqrt*(cp13*ztr 
    171      &           +cp14)+sal*(cp15*ztr+cp16) 
    172             ckp2 = cp20+cp21*ztr+cp22*zlogt+zsqrt*(cp23*ztr 
    173      &           +cp24)+sal*(cp25*ztr+cp26) 
    174             ckp3 = cp30+cp31*ztr+zsqrt*(cp32*ztr 
    175      &           +cp33)+sal*(cp34*ztr+cp35) 
    176             cksi = cs10+cs11*ztr+cs12*zlogt+zisqrt*(cs13*ztr 
    177      &           +cs14)+zis*(cs15*ztr+cs16)+zis2*(cs17*ztr 
    178      &           +cs18)+log(1.+cs19*sal) 
    179      &           +log(cs20+cs21*sal) 
    180  
    181 C 
    182 C*2.7 APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
    183 C       (S=27-43, T=2-25 DEG C) AT pres =0 (ATMOSPH. PRESSURE) 
    184 C       (MUCCI 1983) 
    185 C ------------------------------------------------------------- 
    186 C 
    187             aksp0 = akcc1+akcc2*tkel+akcc3*ztr+akcc4*log10(tkel)+ 
    188      &      (akcc5+akcc6*tkel+ 
    189      &      akcc7*ztr)*zsqrt+akcc8*sal+akcc9*sal15 
    190  
    191  
    192 C 
    193 C* 2.6 K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 
    194 C ----------------------------------------------------------------- 
    195 C 
    196             ak1   = 10**(ck1) 
    197             ak2   = 10**(ck2) 
    198             akb   = exp(ckb) 
    199             akp1  = exp(ckp1) 
    200             akp2  = exp(ckp2) 
    201             akp3  = exp(ckp3) 
    202             aksi  = exp(cksi) 
    203             akw   = exp(ckw) 
    204             aksp1 = 10**(aksp0) 
    205             aks   = exp(cks) 
    206             akf   = exp(ckf) 
    207  
    208  
    209 C 
    210 C* 2.8 FORMULA FOR CPEXP AFTER EDMOND AND GIESKES (1970) 
    211 C        (REFERENCE TO CULBERSON AND PYTKOQICZ (1968) AS MADE 
    212 C        IN BROECKER ET AL. (1982) IS INCORRECT; HERE RGAS IS 
    213 C        TAKEN TENFOLD TO CORRECT FOR THE NOTATION OF pres  IN 
    214 C        DBAR INSTEAD OF BAR AND THE EXPRESSION FOR CPEXP IS 
    215 C        MULTIPLIED BY LN(10.) TO ALLOW USE OF EXP-FUNCTION 
    216 C        WITH BASIS E IN THE FORMULA FOR AKSPP (CF. EDMOND 
    217 C        AND GIESKES (1970), P. 1285 AND P. 1286 (THE SMALL 
    218 C        FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE 
    219 C        SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON 
    220 C        P. 1285)) 
    221 C ----------------------------------------------------------- 
    222 C 
    223             cpexp = pres /(rgas*tkel) 
    224             cpexp2 = pres * pres/(rgas*tkel) 
    225 C 
    226 C* 2.9 KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE 
    227 C        CORRECTION AFTER CULBERSON AND PYTKOWICZ (1968) 
    228 C        (CF. BROECKER ET AL., 1982) 
    229 C -------------------------------------------------------- 
    230 C 
    231             zbuf1 = -(devk1(3)+devk2(3)*tc+devk3(3)*tc*tc) 
    232             zbuf2 = 0.5*(devk4(3)+devk5(3)*tc) 
    233             akb3(ji,jj,jk) = akb*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    234  
    235             zbuf1 = -(devk1(1)+devk2(1)*tc+devk3(1)*tc*tc) 
    236             zbuf2 = 0.5*(devk4(1)+devk5(1)*tc) 
    237             ak13(ji,jj,jk) = ak1*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    238  
    239             zbuf1 = -(devk1(2)+devk2(2)*tc+devk3(2)*tc*tc) 
    240             zbuf2 = 0.5*(devk4(2)+devk5(2)*tc) 
    241             ak23(ji,jj,jk) = ak2*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    242  
    243             zbuf1 = -(devk1(4)+devk2(4)*tc+devk3(4)*tc*tc) 
    244             zbuf2 = 0.5*(devk4(4)+devk5(4)*tc) 
    245             akp13(ji,jj,jk) = akp1*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    246  
    247             zbuf1 = -(devk1(5)+devk2(5)*tc+devk3(5)*tc*tc) 
    248             zbuf2 = 0.5*(devk4(5)+devk5(5)*tc) 
    249             akp23(ji,jj,jk) = akp2*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    250  
    251             zbuf1 = -(devk1(6)+devk2(6)*tc+devk3(6)*tc*tc) 
    252             zbuf2 = 0.5*(devk4(6)+devk5(6)*tc) 
    253             akp33(ji,jj,jk) = akp3*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    254  
    255             zbuf1 = -(devk1(7)+devk2(7)*tc+devk3(7)*tc*tc) 
    256             zbuf2 = 0.5*(devk4(7)+devk5(7)*tc) 
    257             akw3(ji,jj,jk) = akw*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    258  
    259 C  Ksi 
    260 C            aksi3(ji,jj,jk) = aksi 
    261 C 
    262 C  Or using coefficient of borates (cf millero 95+ corrected version html doc co2sys) 
    263 C  "deltaVsi and deltaKsi have been estimated from the value of boric acid" 
    264 C 
    265             zbuf1 = -(devk1(3)+devk2(3)*tc+devk3(3)*tc*tc) 
    266             zbuf2 = 0.5*(devk4(3)+devk5(3)*tc) 
    267             aksi3(ji,jj,jk) = aksi*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    268  
    269 C 
    270 C 
    271 C* 2.15 APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE  
    272 C        AS FUNCTION OF PRESSURE FOLLOWING MILLERO 
    273 C        (P. 1285) AND BERNER (1976) 
    274 C ------------------------------------------------- 
    275  
    276             zbuf1 = -(devk1(8)+devk2(8)*tc+devk3(8)*tc*tc) 
    277             zbuf2 = 0.5*(devk4(8)+devk5(8)*tc) 
    278             aksp(ji,jj,jk) = aksp1*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    279  
    280 C  Pressure correction for sulfate and fluoride 
    281 C 
    282             zbuf1 = -(devk1(9)+devk2(9)*tc+devk3(9)*tc*tc) 
    283             zbuf2 = 0.5*(devk4(9)+devk5(9)*tc) 
    284             aks3(ji,jj,jk) = aks*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    285  
    286             zbuf1 = -(devk1(10)+devk2(10)*tc+devk3(10)*tc*tc) 
    287             zbuf2 = 0.5*(devk4(10)+devk5(10)*tc) 
    288             akf3(ji,jj,jk) = akf*exp(zbuf1*cpexp+zbuf2*cpexp2) 
    289  
    290  
    291 C 
    292 C* 2.11 TOTAL BORATE CONCENTR. [MOLES/L] 
    293 C -------------------------------------- 
    294 C 
    295             borat(ji,jj,jk) = bor1*cl*bor2 
    296 C 
    297 C  2.12 Iron and SIO3 saturation concentration from ... 
    298 C  ---------------------------------------------------- 
    299 C 
    300          sio3eq(ji,jj,jk)=exp(log(10.)*(6.44-968./tkel))*1E-6 
    301          fekeq(ji,jj,jk)=10**(17.27-1565.7/(273.15+tc)) 
    302 C 
    303           ENDDO 
    304         ENDDO 
     84 
     85      ! CHEMICAL CONSTANTS - DEEP OCEAN 
     86      ! ------------------------------- 
     87 
     88      DO jk = 1, jpk 
     89         DO jj = 1, jpj 
     90            DO ji = 1, jpi 
     91 
     92               ! SET PRESSION 
     93               zpres   = 1.025e-1 * fsdept(ji,jj,jk) 
     94 
     95               ! SET ABSOLUTE TEMPERATURE 
     96               ztkel   = tn(ji,jj,jk) + 273.16 
     97               zqtt    = ztkel * 0.01 
     98               zsal    = sn(ji,jj,jk) + ( 1.-tmask(ji,jj,jk) ) * 35. 
     99               zsqrt  = SQRT( zsal ) 
     100               zsal15  = zsqrt * zsal 
     101               zlogt  = LOG( ztkel ) 
     102               ztr    = 1. / ztkel 
     103               zis    = 19.924 * zsal / ( 1000.- 1.005 * zsal ) 
     104               zis2   = zis * zis 
     105               zisqrt = SQRT( zis ) 
     106               ztc     = tn(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 20. 
     107 
     108               ! CHLORINITY (WOOSTER ET AL., 1969) 
     109               zcl     = zsal * salchl 
     110 
     111               ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] 
     112               zst     = st1 * zcl * st2 
     113 
     114               ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] 
     115               zft     = ft1 * zcl * ft2 
     116 
     117               ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 
     118               zcks    = EXP(  ks1 * ztr + ks0 + ks2 * zlogt                           & 
     119                  &                     + ( ks3 * ztr + ks4 + ks5 * zlogt ) * zisqrt   & 
     120                  &                     + ( ks6 * ztr + ks7 + ks8 * zlogt ) * zis      & 
     121                  &                     + ks9 * ztr * zis * zisqrt + ks10 * ztr *zis2 + LOG( ks11 + ks12 *zsal )  ) 
     122 
     123               ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 
     124               zckf    = EXP(  kf1 * ztr + kf0 + kf2 * zisqrt + LOG( kf3 + kf4 * zsal )  ) 
     125 
     126               ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 
     127               zckb    = ( cb0 + cb1 * zsqrt + cb2  * zsal + cb3 * zsal15 + cb4 * zsal * zsal ) * ztr   & 
     128                  &    + ( cb5 + cb6 * zsqrt + cb7  * zsal )                                            & 
     129                  &    + ( cb8 + cb9 * zsqrt + cb10 * zsal ) * zlogt + cb11 * zsqrt * ztkel             & 
     130                  &    + LOG(  ( 1.+ zst / zcks + zft / zckf ) / ( 1.+ zst / zcks )  ) 
     131!!gm zsal**2 to be replaced by a *... 
     132               zck1    = c10 * ztr + c11 + c12 * zlogt + c13 * zsal + c14 * zsal**2 
     133               zck2    = c20 * ztr + c21 + c22 * zsal   + c23 * zsal**2 
     134 
     135               ! PKW (H2O) (DICKSON AND RILEY, 1979) 
     136               zckw    = cw0 * ztr + cw1 + cw2 * zlogt + ( cw3 * ztr + cw4 + cw5 * zlogt ) * zsqrt + cw6 * zsal 
     137 
     138               ! DISSOCIATION CONSTANT FOR PHOSPHATE AND SILICATE (seawater scale) 
     139               zckp1 = cp10 + cp11 * ztr + cp12 * zlogt + zsqrt * ( cp13 * ztr + cp14 ) + zsal * ( cp15 * ztr + cp16 ) 
     140               zckp2 = cp20 + cp21 * ztr + cp22 * zlogt + zsqrt * ( cp23 * ztr + cp24 ) + zsal * ( cp25 * ztr + cp26 ) 
     141               zckp3 = cp30 + cp31 * ztr                + zsqrt * ( cp32 * ztr + cp33 ) + zsal * ( cp34 * ztr + cp35 ) 
     142               zcksi = cs10 + cs11 * ztr + cs12 * zlogt + zisqrt* ( cs13 * ztr + cs14 ) + zis * ( cs15 * ztr + cs16 )  & 
     143                  &                                    + zis2  * ( cs17 * ztr + cs18 ) + LOG( 1.   + cs19 * zsal )     & 
     144                  &                                                                    + LOG( cs20 + cs21 * zsal ) 
     145 
     146               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
     147               !       (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) 
     148               zaksp0  = akcc1 + akcc2 * ztkel + akcc3 * ztr + akcc4 * LOG10( ztkel )   & 
     149                  &   + ( akcc5 + akcc6 * ztkel + akcc7 * ztr ) * zsqrt + akcc8 * zsal + akcc9 * zsal15 
     150 
     151               ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 
     152               zak1    = 10**(zck1) 
     153               zak2    = 10**(zck2) 
     154               zakb    = EXP( zckb  ) 
     155               zakp1   = EXP( zckp1 ) 
     156               zakp2   = EXP( zckp2 ) 
     157               zakp3   = EXP( zckp3 ) 
     158               zaksi   = EXP( zcksi ) 
     159               zakw    = EXP( zckw ) 
     160               zaksp1  = 10**(zaksp0) 
     161               zaks    = exp( zcks ) 
     162               zakf    = exp( zckf ) 
     163 
     164               ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) 
     165               !        (REFERENCE TO CULBERSON & PYTKOQICZ (1968) AS MADE 
     166               !        IN BROECKER ET AL. (1982) IS INCORRECT; HERE RGAS IS 
     167               !        TAKEN TENFOLD TO CORRECT FOR THE NOTATION OF pres  IN 
     168               !        DBAR INSTEAD OF BAR AND THE EXPRESSION FOR CPEXP IS 
     169               !        MULTIPLIED BY LN(10.) TO ALLOW USE OF EXP-FUNCTION 
     170               !        WITH BASIS E IN THE FORMULA FOR AKSPP (CF. EDMOND 
     171               !        & GIESKES (1970), P. 1285-1286 (THE SMALL 
     172               !        FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE 
     173               !        SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) 
     174               zcpexp  = zpres /(rgas*ztkel) 
     175               zcpexp2 = zpres * zpres/(rgas*ztkel) 
     176 
     177               ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE 
     178               !        CORRECTION AFTER CULBERSON AND PYTKOWICZ (1968) 
     179               !        (CF. BROECKER ET AL., 1982) 
     180               zbuf1  =     - ( devk1(3) + devk2(3) * ztc + devk3(3) * ztc * ztc ) 
     181               zbuf2  = 0.5 * ( devk4(3) + devk5(3) * ztc ) 
     182               akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     183 
     184               zbuf1  = -(devk1(1)+devk2(1)*ztc+devk3(1)*ztc*ztc) 
     185               zbuf2  = 0.5*(devk4(1)+devk5(1)*ztc) 
     186               ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     187 
     188               zbuf1  =     - ( devk1(2) + devk2(2) * ztc + devk3(2) * ztc * ztc ) 
     189               zbuf2  = 0.5 * ( devk4(2) + devk5(2) * ztc ) 
     190               ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     191 
     192               zbuf1  =     - ( devk1(4) + devk2(4) * ztc + devk3(4) * ztc * ztc ) 
     193               zbuf2  = 0.5 * ( devk4(4) + devk5(4) * ztc ) 
     194               akp13(ji,jj,jk) = zakp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     195 
     196               zbuf1  =     - ( devk1(5) + devk2(5) * ztc + devk3(5) * ztc * ztc ) 
     197               zbuf2  = 0.5 * ( devk4(5) + devk5(5) * ztc ) 
     198               akp23(ji,jj,jk) = zakp2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     199 
     200               zbuf1  =     - ( devk1(6) + devk2(6) * ztc + devk3(6) * ztc * ztc ) 
     201               zbuf2  = 0.5 * ( devk4(6) + devk5(6) * ztc ) 
     202               akp33(ji,jj,jk) = zakp3 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     203 
     204               zbuf1  =     - ( devk1(7) + devk2(7) * ztc + devk3(7) * ztc * ztc ) 
     205               zbuf2  = 0.5 * ( devk4(7) + devk5(7) * ztc ) 
     206               akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     207 
     208               !  Ksi 
     209               !            aksi3(ji,jj,jk) = zaksi 
     210               ! 
     211               !  Or using coefficient of borates (cf millero 95+ corrected version html doc co2sys) 
     212               !  "deltaVsi and deltaKsi have been estimated from the value of boric acid" 
     213               zbuf1  =     - ( devk1(3) + devk2(3) * ztc + devk3(3) * ztc * ztc ) 
     214               zbuf2  = 0.5 * ( devk4(3) + devk5(3) * ztc ) 
     215               aksi3(ji,jj,jk) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     216 
     217               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE  
     218               !        AS FUNCTION OF PRESSURE FOLLOWING MILLERO 
     219               !        (P. 1285) AND BERNER (1976) 
     220               zbuf1  =     - ( devk1(8) + devk2(8) * ztc + devk3(8) * ztc * ztc ) 
     221               zbuf2  = 0.5 * ( devk4(8) + devk5(8) * ztc ) 
     222               aksp(ji,jj,jk) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     223 
     224               !  Pressure correction for sulfate and fluoride 
     225               zbuf1  =     - ( devk1(9) + devk2(9) * ztc + devk3(9) * ztc * ztc ) 
     226               zbuf2  = 0.5 * ( devk4(9) + devk5(9) * ztc ) 
     227               aks3(ji,jj,jk) = zaks   * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     228 
     229               zbuf1  =     - ( devk1(10) + devk2(10) * ztc + devk3(10) * ztc * ztc ) 
     230               zbuf2  = 0.5 * ( devk4(10) + devk5(10) * ztc ) 
     231               akf3(ji,jj,jk) = zakf   * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 
     232 
     233               ! TOTAL BORATE CONCENTR. [MOLES/L] 
     234               borat(ji,jj,jk) = bor1 * zcl * bor2 
     235 
     236               ! Iron and SIO3 saturation concentration from ... 
     237               sio3eq(ji,jj,jk) = EXP(  LOG( 10.) * ( 6.44 - 968. / ztkel )  ) * 1.e-6 
     238               fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ( 273.15 + ztc ) ) 
     239 
     240            END DO 
     241         END DO 
    305242      END DO 
    306 C 
    307 #endif 
    308 C 
    309       RETURN 
    310       END 
     243      ! 
     244   END SUBROUTINE p4z_che 
     245 
     246#else 
     247   !!====================================================================== 
     248   !!  Dummy module :                                   No PISCES bio-model 
     249   !!====================================================================== 
     250CONTAINS 
     251   SUBROUTINE p4z_che( kt )                   ! Empty routine 
     252      INTEGER, INTENT( in ) ::   kt 
     253      WRITE(*,*) 'p4z_che: You should not have seen this print! error?', kt 
     254   END SUBROUTINE p4z_che 
     255#endif  
     256 
     257   !!====================================================================== 
     258END MODULE  p4zche 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zday.F90

    r774 r775  
    1 CCC$Header$ 
    2 CCC  TOP 1.0 , LOCEAN-IPSL (2005) 
    3 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt 
    4 C --------------------------------------------------------------------------- 
    5 CDIR$ LIST 
    6       SUBROUTINE p4zday 
    7 #if defined key_top && defined key_pisces 
    8 CCC--------------------------------------------------------------------- 
    9 CCC 
    10 CCC          ROUTINE p4zday : PISCES MODEL 
    11 CCC          ***************************** 
    12 CCC 
    13 CCC  PURPOSE : 
    14 CCC  --------- 
    15 CCC        PISCES : compute the day length depending on latitude 
    16 CCC                 and the day 
    17 CCC 
    18 CC   INPUT : 
    19 CC   ----- 
    20 CC      argument 
    21 CC              ktask           : task identificator 
    22 CC      common 
    23 CC              all the common defined in opa 
    24 CC 
    25 CC 
    26 CC   OUTPUT :                   : no 
    27 CC   ------ 
    28 CC 
    29 CC   EXTERNAL : 
    30 CC   -------- 
    31 CC            None 
    32 CC 
    33 CC   MODIFICATIONS: 
    34 CC   -------------- 
    35 CC      original  : E. Maier-Reimer (GBC 1993) 
    36 CC      additions : C. Le Quere (1999) 
    37 CC      modifications : O. Aumont (2004) 
    38 CC---------------------------------------------------------------------- 
    39 CC parameters and commons 
    40 CC ====================== 
    41       USE oce_trc 
    42       USE trp_trc 
    43       USE sms 
    44       IMPLICIT NONE 
    45 CC---------------------------------------------------------------------- 
    46 CC local declarations 
    47 CC ================== 
    48       INTEGER ji, jj, iyy 
    49       REAL rum, delta, codel, phi, argu 
    50 C 
    51 C Get year 
    52 C -------- 
    53 C 
    54       iyy = ndastp/10000 
     1MODULE p4zday 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zday  *** 
     4   !! TOP :   PISCES compute the day length depending on latitude and the day 
     5   !!====================================================================== 
     6   !! History :    -   !  1993     (E. Maier-Reimer) Original code GBC 1993 
     7   !!              -   !  1999     (C. Le Quere) 
     8   !!             1.0  !  2004     (O. Aumont) Original code 
     9   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     10   !!---------------------------------------------------------------------- 
     11#if defined key_pisces 
     12   !!---------------------------------------------------------------------- 
     13   !!   'key_pisces'                                       PISCES bio-model 
     14   !!---------------------------------------------------------------------- 
     15   !!   p4z_day       :   compute the day length depending on latitude and the day 
     16   !!---------------------------------------------------------------------- 
     17   USE oce_trc         ! 
     18   USE trp_trc         !  
     19   USE sms             !  
    5520 
    56        IF(lwp) write(numout,*) 
    57        IF(lwp) write(numout,*) 'p4zday - Julian day ', nday_year 
    58        IF(lwp) write(numout,*) 
     21   IMPLICIT NONE 
     22   PRIVATE 
     23 
     24   PUBLIC   p4z_day    ! called in p4zprod.F90 
     25 
     26   !!* Substitution 
     27#  include "domzgr_substitute.h90" 
     28   !!---------------------------------------------------------------------- 
     29   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     30   !! $Header:$  
     31   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     32   !!---------------------------------------------------------------------- 
     33 
     34CONTAINS 
     35 
     36   SUBROUTINE p4z_day 
     37      !!--------------------------------------------------------------------- 
     38      !!                     ***  ROUTINE p4z_day  *** 
     39      !! 
     40      !! ** Purpose :   compute the day length depending on latitude and the day 
     41      !! 
     42      !! ** Method  : - ??? 
     43      !!--------------------------------------------------------------------- 
     44      INTEGER  ::   ji, jj 
     45      INTEGER  ::   iyy 
     46      REAL(wp) ::   zrum, zdelta, zcodel, zphi, zargu 
     47      !!--------------------------------------------------------------------- 
     48 
     49      ! Get year 
     50      ! -------- 
     51 
     52      iyy = ndastp / 10000 
     53 
     54      IF(lwp) write(numout,*) 
     55      IF(lwp) write(numout,*) 'p4zday : - Julian day ', nday_year 
     56      IF(lwp) write(numout,*) '~~~~~~' 
    5957 
    6058 
    61       IF (nleapy.EQ.1 .AND. MOD(iyy,4).EQ.0) THEN 
    62           rum = FLOAT(nday_year-80)/366. 
     59      IF( nleapy == 1 .AND. MOD( iyy, 4 ) == 0 ) THEN 
     60         zrum = FLOAT( nday_year - 80 ) / 366. 
    6361      ELSE 
    64           rum = FLOAT(nday_year-80)/365. 
     62         zrum = FLOAT( nday_year - 80 ) / 365. 
    6563      ENDIF 
    6664 
    67 C 
    68       delta = SIN(rum*rpi*2.)*sin(rpi*23.5/180.) 
    69       codel = asin(delta) 
     65      zdelta = SIN( zrum * rpi * 2. ) * sin( rpi * 23.5 / 180. ) 
     66      zcodel = ASIN( zdelta ) 
    7067 
    71       DO jj = 1,jpj 
    72         DO ji = 1,jpi 
    73           phi = gphit(ji,jj)*rpi/180. 
    74           argu = tan(codel)*tan(phi) 
    75           strn(ji,jj) = 0. 
    76           argu=min(1.,argu) 
    77           argu=max(-1.,argu) 
    78           strn(ji,jj)=24.-2.*acos(argu)*180./rpi/15. 
    79           strn(ji,jj)=max(strn(ji,jj),0.) 
    80         END DO 
     68      DO jj = 1, jpj 
     69         DO ji = 1, jpi 
     70            zphi = gphit(ji,jj) * rpi / 180. 
     71            zargu = TAN( zcodel ) * TAN( zphi ) 
     72            strn(ji,jj) = 0.e0 
     73            zargu = MIN(  1., zargu ) 
     74            zargu = MAX( -1., zargu ) 
     75            strn(ji,jj) = 24.- 2.* ACOS( zargu ) * 180./ rpi / 15. 
     76            strn(ji,jj) = MAX( strn(ji,jj), 0.e0 ) 
     77         END DO 
    8178      END DO 
    82 C 
    83 #endif 
    84       RETURN 
    85       END 
     79      ! 
     80   END SUBROUTINE p4z_day 
     81 
     82#else 
     83   !!====================================================================== 
     84   !!  Dummy module :                                   No PISCES bio-model 
     85   !!====================================================================== 
     86CONTAINS 
     87   SUBROUTINE p4z_day                    ! Empty routine 
     88   END SUBROUTINE p4z_day 
     89#endif  
     90 
     91   !!====================================================================== 
     92END MODULE  p4zday 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zdiat.F90

    r774 r775  
     1MODULE p4zdiat 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zdiat  *** 
     4   !! TOP :   PISCES Compute the mortality terms for diatoms 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2002     (O. Aumont)  Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_diat       :   Compute the mortality terms for diatoms 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc         !  
     17   USE sms             !  
    118 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zdiat 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC           ROUTINE p4zdiat : PISCES MODEL 
    12 CCC           ****************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the mortality terms for diatoms 
    17 CCC 
    18 CC   INPUT : 
    19 CC   ----- 
    20 CC      argument 
    21 CC              None 
    22 CC      common 
    23 CC              all the common defined in opa 
    24 CC 
    25 CC 
    26 CC   OUTPUT :                   : no 
    27 CC   ------ 
    28 CC 
    29 CC   EXTERNAL : 
    30 CC   -------- 
    31 CC           None 
    32 CC 
    33 CC   MODIFICATIONS: 
    34 CC   -------------- 
    35 CC      original  : O. Aumont (2002) 
    36 CC---------------------------------------------------------------------- 
    37 CC parameters and commons 
    38 CC ====================== 
    39 CDIR$ NOLIST 
    40       USE oce_trc 
    41       USE trp_trc 
    42       USE sms 
    43       IMPLICIT NONE 
    44 CDIR$ LIST 
    45 CC---------------------------------------------------------------------- 
    46 CC local declarations 
    47 CC ================== 
    48       INTEGER ji, jj, jk 
    49       REAL zfact,zstep,compadi 
    50 C 
    51 C      Time step duration for biology 
    52 C      ------------------------------ 
    53 C 
    54         zstep=rfact2/rjjss 
    55 C 
    56 C    Aggregation term for diatoms is increased in case of nutrient 
    57 C    stress as observed in reality. The stressed cells become more 
    58 C    sticky and coagulate to sink quickly out of the euphotic zone 
    59 C     ------------------------------------------------------------ 
    60 C 
    61         DO jk = 1,jpkm1 
    62           DO jj = 1,jpj 
    63             DO ji = 1,jpi 
    64 C 
    65         compadi = max((trn(ji,jj,jk,jpdia)-1E-8),0.) 
    66         zfact=1./(trn(ji,jj,jk,jpdia)+rtrn) 
    67 C 
    68 C    Aggregation term for diatoms is increased in case of nutrient 
    69 C    stress as observed in reality. The stressed cells become more 
    70 C    sticky and coagulate to sink quickly out of the euphotic zone 
    71 C     ------------------------------------------------------------ 
    72 C 
    73         respp2(ji,jj,jk) = 1E6*zstep 
    74      &    *(wchl+wchld*(1.-xlimdia(ji,jj,jk))) 
    75      &    *zdiss(ji,jj,jk)*compadi*trn(ji,jj,jk,jpdia) 
    76 #    if defined key_off_degrad 
    77      &    *facvol(ji,jj,jk) 
    78 #    endif 
     19   IMPLICIT NONE 
     20   PRIVATE 
     21 
     22   PUBLIC   p4z_diat    ! called in p4zbio.F90 
     23 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
     31 
     32CONTAINS 
     33 
     34   SUBROUTINE p4z_diat 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_diat  *** 
     37      !! 
     38      !! ** Purpose :   Compute the mortality terms for diatoms 
     39      !! 
     40      !! ** Method  : - ??? 
     41      !!--------------------------------------------------------------------- 
     42      INTEGER  ::   ji, jj, jk 
     43      REAL(wp) ::   zfact, zstep, zcompadi 
     44      !!--------------------------------------------------------------------- 
     45 
     46        zstep = rfact2 / rjjss      ! Time step duration for biology 
     47 
     48 
     49!    Aggregation term for diatoms is increased in case of nutrient 
     50!    stress as observed in reality. The stressed cells become more 
     51!    sticky and coagulate to sink quickly out of the euphotic zone 
     52!     ------------------------------------------------------------ 
     53 
     54      DO jk = 1, jpkm1 
     55         DO jj = 1, jpj 
     56            DO ji = 1, jpi 
     57 
     58               zcompadi = MAX( ( trn(ji,jj,jk,jpdia) - 1e-8), 0. ) 
     59               zfact    = 1. / ( trn(ji,jj,jk,jpdia) + rtrn ) 
     60 
     61!    Aggregation term for diatoms is increased in case of nutrient 
     62!    stress as observed in reality. The stressed cells become more 
     63!    sticky and coagulate to sink quickly out of the euphotic zone 
     64!     ------------------------------------------------------------ 
     65 
     66               respp2 (ji,jj,jk) = 1.e6 * zstep * (  wchl + wchld * ( 1.- xlimdia(ji,jj,jk) )  )    & 
     67# if defined key_off_degrad 
     68                  &              * facvol(ji,jj,jk)       & 
     69# endif 
     70                  &              * zdiss(ji,jj,jk) * zcompadi * trn(ji,jj,jk,jpdia) 
    7971                                                                                
    80         respds(ji,jj,jk) = respp2(ji,jj,jk) 
    81      &    *trn(ji,jj,jk,jpbsi)*zfact 
     72               respds (ji,jj,jk) = respp2(ji,jj,jk) * trn(ji,jj,jk,jpbsi) * zfact 
    8273 
    83         respdf(ji,jj,jk) = respp2(ji,jj,jk) 
    84      &    *trn(ji,jj,jk,jpdfe)*zfact 
     74               respdf (ji,jj,jk) = respp2(ji,jj,jk) * trn(ji,jj,jk,jpdfe) * zfact 
    8575                                                                                
    86         respdch(ji,jj,jk)=respp2(ji,jj,jk) 
    87      &    *trn(ji,jj,jk,jpdch)*zfact 
    88 C 
    89 C     Phytoplankton mortality.  
    90 C     ------------------------ 
    91 C 
    92         tortp2(ji,jj,jk) = mprat2*zstep*trn(ji,jj,jk,jpdia) 
    93      &    /(xkmort+trn(ji,jj,jk,jpdia))*compadi 
    94 #    if defined key_off_degrad 
    95      &    *facvol(ji,jj,jk) 
    96 #    endif 
     76               respdch(ji,jj,jk) = respp2(ji,jj,jk) * trn(ji,jj,jk,jpdch) * zfact 
    9777 
    98         tortds(ji,jj,jk) = tortp2(ji,jj,jk) 
    99      &    *trn(ji,jj,jk,jpbsi)*zfact 
     78!     Phytoplankton mortality.  
     79!     ------------------------ 
     80               tortp2 (ji,jj,jk) = mprat2 * zstep * trn(ji,jj,jk,jpdia)     & 
     81# if defined key_off_degrad 
     82                  &              * facvol(ji,jj,jk)       & 
     83# endif 
     84                  &              / ( xkmort + trn(ji,jj,jk,jpdia) ) * zcompadi 
    10085 
    101         tortdf(ji,jj,jk)=tortp2(ji,jj,jk) 
    102      &    *trn(ji,jj,jk,jpdfe)*zfact 
     86               tortds (ji,jj,jk) = tortp2(ji,jj,jk) * trn(ji,jj,jk,jpbsi) * zfact 
    10387 
    104         tortdch(ji,jj,jk)=tortp2(ji,jj,jk) 
    105      &    *trn(ji,jj,jk,jpdch)*zfact 
    106 C 
     88               tortdf (ji,jj,jk) = tortp2(ji,jj,jk) * trn(ji,jj,jk,jpdfe) * zfact 
     89 
     90               tortdch(ji,jj,jk) = tortp2(ji,jj,jk) * trn(ji,jj,jk,jpdch) * zfact 
     91 
    10792            END DO 
    108           END DO 
    109         END DO 
    110 C 
    111 #endif 
    112       RETURN 
    113       END 
     93         END DO 
     94      END DO 
     95      ! 
     96   END SUBROUTINE p4z_diat 
     97 
     98#else 
     99   !!====================================================================== 
     100   !!  Dummy module :                                   No PISCES bio-model 
     101   !!====================================================================== 
     102CONTAINS 
     103   SUBROUTINE p4z_diat                    ! Empty routine 
     104   END SUBROUTINE p4z_diat 
     105#endif  
     106 
     107   !!====================================================================== 
     108END MODULE  p4zdiat 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zflx.F90

    r774 r775  
     1MODULE p4zflx 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zflx  *** 
     4   !! TOP :   PISCES CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE 
     5   !!====================================================================== 
     6   !! History :    -   !  1988-07  (E. MAIER-REIMER) Original code 
     7   !!              -   !  1998     (O. Aumont) additions 
     8   !!              -   !  1999     (C. Le Quere) modifications 
     9   !!             1.0  !  2004     (O. Aumont) modifications 
     10   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     11   !!---------------------------------------------------------------------- 
     12#if defined key_pisces 
     13   !!---------------------------------------------------------------------- 
     14   !!   'key_pisces'                                       PISCES bio-model 
     15   !!---------------------------------------------------------------------- 
     16   !!   p4z_flx       :   CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE 
     17   !!---------------------------------------------------------------------- 
     18   USE oce_trc         ! 
     19   USE trp_trc 
     20   USE sms 
    121 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zflx 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC          ROUTINE p4zflx : PISCES MODEL 
    12 CCC          ***************************** 
    13 CCC 
    14 CCC 
    15 CC     PURPOSE. 
    16 CC     -------- 
    17 CC          *P4ZFLX* CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE 
    18 CC 
    19 CC     EXTERNALS. 
    20 CC     ---------- 
    21 CC          NONE. 
    22 CC 
    23 CC   MODIFICATIONS: 
    24 CC   -------------- 
    25 CC      original      : 1988-07 E. MAIER-REIMER      MPI HAMBURG 
    26 CC      additions     : 1998    O. Aumont 
    27 CC      modifications : 1999    C. Le Quere 
    28 CC      modifications : 2004    O. Aumont 
    29 CC     ----------------------------------------------------------------- 
    30 CC  parameters and commons 
    31 CC ====================== 
    32 CDIR$ NOLIST 
    33       USE oce_trc 
    34       USE trp_trc 
    35       USE sms 
    36       IMPLICIT NONE 
    37 #include "domzgr_substitute.h90" 
    38 CDIR$ LIST 
    39 CC---------------------------------------------------------------------- 
    40 CC local declarations 
    41 CC ================== 
    42 C 
    43       INTEGER nspyr, ji, jj, krorr 
    44       REAL zpdtan 
    45       REAL kgco2(jpi,jpj),kgo2(jpi,jpj),h2co3(jpi,jpj) 
    46       REAL ttc, ws 
    47       REAL fld, flu, oxy16, flu16, zfact 
    48       REAL zph,ah2,zbot,zdic,zalk,schmitto2, zalka 
    49       REAL schmittco2 
    50 C 
    51 C 
    52 C  1. ASSIGNATION TO EXPONENTS IN THE LISS AND MERLIVAT 
    53 C     FORMULATION OF THE GAS EXCHANGE RATE 
    54 c ----------------------------------------------------- 
    55 C 
     22   IMPLICIT NONE 
     23   PRIVATE 
     24 
     25   PUBLIC   p4z_flx    ! called in p4zprg.F90 
     26 
     27   !!* Substitution 
     28#  include "domzgr_substitute.h90" 
     29   !!---------------------------------------------------------------------- 
     30   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     31   !! $Header:$  
     32   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     33   !!---------------------------------------------------------------------- 
     34 
     35CONTAINS 
     36 
     37   SUBROUTINE p4z_flx 
     38      !!--------------------------------------------------------------------- 
     39      !!                     ***  ROUTINE p4z_flx  *** 
     40      !! 
     41      !! ** Purpose :   CALCULATES GAS EXCHANGE AND CHEMISTRY AT SEA SURFACE 
     42      !! 
     43      !! ** Method  : - ??? 
     44      !!--------------------------------------------------------------------- 
     45      INTEGER  ::   ji, jj, jrorr 
     46      REAL(wp) ::   zpdtan, zttc, zws 
     47      REAL(wp) ::   zfld, zflu, zoxy16, zflu16, zfact 
     48      REAL(wp) ::   zph, zah2, zbot, zdic, zalk, zschmitto2, zalka, zschmittco2 
     49      REAL(wp), DIMENSION(jpi,jpj) ::   zkgco2, zkgo2, zh2co3 
     50      !!--------------------------------------------------------------------- 
     51 
     52      ! ----------------------------------------------------- 
     53      !     ASSIGNATION TO EXPONENTS IN THE LISS AND MERLIVAT 
     54      !     FORMULATION OF THE GAS EXCHANGE RATE 
     55      ! ----------------------------------------------------- 
     56 
    5657      zpdtan = raass / rdt 
    57       nspyr  = nint(zpdtan) 
    5858 
    59 C 
    60 C* 1.1 SURFACE CHEMISTRY (PCO2 AND [H+] IN 
    61 C     SURFACE LAYER); THE RESULT OF THIS CALCULATION 
    62 C     IS USED TO COMPUTE AIR-SEA FLUX OF CO2 
    63 C --------------------------------------------------- 
    64 C 
    65       DO krorr = 1,10 
    66 C 
    67         DO jj = 1,jpj 
    68           DO ji = 1,jpi 
    69 C 
    70 C* 1.2 DUMMY VARIABLES FOR DIC, H+, AND BORATE 
    71 C -------------------------------------------- 
    72 C 
    73         zbot = borat(ji,jj,1) 
    74         zfact = rhop(ji,jj,1)/1000.+rtrn 
    75         zdic  = trn(ji,jj,1,jpdic)/zfact 
    76         zph = max(hi(ji,jj,1),1.E-10)/zfact 
    77         zalka = trn(ji,jj,1,jptal)/zfact 
    78 C 
    79 C* 1.3 CALCULATE [ALK]([CO3--], [HCO3-]) 
    80 C ------------------------------------ 
    81 C 
    82         zalk=zalka- 
    83      &        (akw3(ji,jj,1)/zph-zph+zbot/(1.+zph/akb3(ji,jj,1))) 
    84 C 
    85 C* 1.4 CALCULATE [H+] AND [H2CO3] 
    86 C ----------------------------------------- 
    87 C 
    88          ah2=sqrt((zdic-zalk)**2+4*(zalk*ak23(ji,jj,1) 
    89      &     /ak13(ji,jj,1))*(2*zdic-zalk)) 
    90         ah2=0.5*ak13(ji,jj,1)/zalk*((zdic-zalk)+ah2) 
    91         h2co3(ji,jj) = (2*zdic-zalk)/(2.+ak13(ji,jj,1)/ah2)*zfact 
    92         hi(ji,jj,1)  = ah2*zfact 
    93           END DO 
    94         END DO 
     59      ! SURFACE CHEMISTRY (PCO2 AND [H+] IN 
     60      !     SURFACE LAYER); THE RESULT OF THIS CALCULATION 
     61      !     IS USED TO COMPUTE AIR-SEA FLUX OF CO2 
     62 
     63      DO jrorr = 1, 10 
     64 
     65         DO jj = 1, jpj 
     66            DO ji = 1, jpi 
     67 
     68               ! DUMMY VARIABLES FOR DIC, H+, AND BORATE 
     69               zbot  = borat(ji,jj,1) 
     70               zfact = rhop(ji,jj,1) / 1000. + rtrn 
     71               zdic  = trn(ji,jj,1,jpdic) / zfact 
     72               zph   = MAX( hi(ji,jj,1), 1.e-10 ) / zfact 
     73               zalka = trn(ji,jj,1,jptal) / zfact 
     74 
     75               ! CALCULATE [ALK]([CO3--], [HCO3-]) 
     76               zalk  = zalka - (  akw3(ji,jj,1) / zph - zph + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
     77 
     78               ! CALCULATE [H+] AND [H2CO3] 
     79               zah2   = SQRT(  (zdic-zalk)**2 + 4.* ( zalk * ak23(ji,jj,1)   & 
     80                  &                                        / ak13(ji,jj,1) ) * ( 2.* zdic - zalk )  ) 
     81               zah2   = 0.5 * ak13(ji,jj,1) / zalk * ( ( zdic - zalk ) + zah2 ) 
     82               zh2co3(ji,jj) = ( 2.* zdic - zalk ) / ( 2.+ ak13(ji,jj,1) / zah2 ) * zfact 
     83               hi(ji,jj,1)   = zah2 * zfact 
     84            END DO 
     85         END DO 
    9586      END DO 
    96 C 
    97 C 
    98 C 2. COMPUTE FLUXES 
    99 C -------------- 
    100 C 
    101 C 2.1 FIRST COMPUTE GAS EXCHANGE COEFFICIENTS 
    102 C ------------------------------------------- 
    103 C 
    104       DO jj = 1,jpj 
    105         DO ji = 1,jpi 
    106 C 
    107           ttc = min(35.,tn(ji,jj,1)) 
    108           schmittco2=2073.1-125.62*ttc+3.6276*ttc**2 
    109      &      -0.043126*ttc**3 
    110           ws=vatm(ji,jj) 
    111 C 
    112 C 2.2 COMPUTE GAS EXCHANGE FOR CO2 
    113 C -------------------------------- 
    114 C 
    115           kgco2(ji,jj) = (0.3*ws*ws + 2.5*(0.5246+ttc*(0.016256+ 
    116      &      ttc*0.00049946)))*sqrt(660./schmittco2) 
    117 C 
    118 C 2.3 CONVERT TO m/s, and apply sea-ice cover 
    119 C ----------------------------------------------------- 
    120 C 
    121           kgco2(ji,jj) = kgco2(ji,jj)/(100.*3600.) 
    122      &      *(1-freeze(ji,jj))*tmask(ji,jj,1) 
    123 #    if defined key_off_degrad 
    124      &        *facvol(ji,jj,1) 
    125 #    endif 
    126 C 
     87 
     88 
     89      ! -------------- 
     90      ! COMPUTE FLUXES 
     91      ! -------------- 
     92 
     93      ! FIRST COMPUTE GAS EXCHANGE COEFFICIENTS 
     94      ! ------------------------------------------- 
     95 
     96      DO jj = 1, jpj 
     97         DO ji = 1, jpi 
     98 
     99            zttc = MIN( 35., tn(ji,jj,1) ) 
     100!!gm  optimisation & more precise computation with factorisation of the polynome 
     101            zschmittco2 = 2073.1 - 125.62 * zttc + 3.6276 * zttc**2 - 0.043126 * zttc**3 
     102            zws         = vatm(ji,jj) 
     103 
     104            ! COMPUTE GAS EXCHANGE FOR CO2 
     105            zkgco2(ji,jj) = (  0.3 * zws * zws    & 
     106               &             + 2.5 * ( 0.5246 + zttc * ( 0.016256 + zttc * 0.00049946 ) )  )   & 
     107               &          * SQRT( 660./ zschmittco2 ) 
     108 
     109            ! CONVERT TO m/s, and apply sea-ice cover 
     110            zkgco2(ji,jj) = zkgco2(ji,jj) / ( 100. * 3600. )      & 
     111# if defined key_off_degrad 
     112               &         * facvol(ji,jj,1)      & 
     113# endif 
     114               &         * ( 1.- freeze(ji,jj) ) * tmask(ji,jj,1) 
     115 
    127116         END DO 
    128        END DO 
    129 C 
    130 C 2.5 COMPUTE GAS EXCHANGE COEFFICIENT FO O2 FROM 
    131 C      Waninkhof EQUATIONS 
    132 C ----------------------------------------------- 
    133 C 
    134        DO jj = 1,jpj 
    135          DO ji = 1,jpi 
    136 C 
    137           ws = vatm(ji,jj) 
    138           ttc = min(35.,tn(ji,jj,1)) 
    139           schmitto2 = 1953.4-128.0*ttc+3.9918*ttc**2 
    140      &      -0.050091*ttc**3 
     117      END DO 
    141118 
    142           kgo2(ji,jj) = (0.3*ws*ws + 2.5*(0.5246+ttc*(0.016256+ 
    143      &      ttc*0.00049946)))*sqrt(660./schmitto2) 
     119      ! COMPUTE GAS EXCHANGE COEFFICIENT FO O2 FROM Waninkhof EQUATIONS 
     120      DO jj = 1, jpj 
     121         DO ji = 1, jpi 
    144122 
    145 C 
    146 C CONVERT TO m/s AND APPLY SEA ICE COVER 
    147 C ------------------------------------- 
    148 C 
    149           kgo2(ji,jj) = kgo2(ji,jj)/(100.*3600.) 
    150      &      *(1-freeze(ji,jj))*tmask(ji,jj,1) 
    151 #    if defined key_off_degrad 
    152      &        *facvol(ji,jj,1) 
    153 #    endif 
    154 C 
    155          ENDDO 
    156        ENDDO 
    157 C 
    158        DO jj = 1,jpj 
    159          DO ji = 1,jpi 
    160 C 
    161 C Compute CO2 flux for the sea and air 
    162 C ------------------------------------ 
    163 C 
    164           fld = atcco2*tmask(ji,jj,1)*chemc(ji,jj,3)*kgco2(ji,jj) 
    165           flu = h2co3(ji,jj)*tmask(ji,jj,1)*kgco2(ji,jj) 
    166           tra(ji,jj,1,jpdic)= tra(ji,jj,1,jpdic)+(fld-flu) 
    167      &      /fse3t(ji,jj,1) 
    168 C 
    169 C Compute O2 flux  
    170 C --------------- 
    171 C 
    172           oxy16 = trn(ji,jj,1,jpoxy) 
    173           flu16 = (atcox*chemc(ji,jj,2)-oxy16)*kgo2(ji,jj) 
    174           tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy)+flu16 
    175      &      /fse3t(ji,jj,1) 
    176 C 
    177 C Save diagnostics 
    178 C ---------------- 
    179 C 
    180 #    if defined key_trc_diaadd 
    181           trc2d(ji,jj,1) = (fld-flu)*1000. 
    182           trc2d(ji,jj,2) = flu16*1000. 
    183           trc2d(ji,jj,3) = kgco2(ji,jj) 
    184           trc2d(ji,jj,4) = atcco2-h2co3(ji,jj)/(chemc(ji,jj,3)+rtrn) 
    185 #    endif 
    186 C 
    187         END DO 
     123          zws  = vatm(ji,jj) 
     124          zttc = MIN( 35., tn(ji,jj,1) ) 
     125!!gm  optimisation & more precise computation with factorisation of the polynome 
     126          zschmitto2   = 1953.4 - 128.0 * zttc + 3.9918 * zttc**2 - 0.050091 * zttc**3 
     127 
     128          zkgo2(ji,jj) = (  0.3 * zws * zws   & 
     129             &            + 2.5 * ( 0.5246 + zttc * ( 0.016256 + zttc * 0.00049946 ) )  )   & 
     130             &         * SQRT( 660./ zschmitto2 ) 
     131 
     132          ! CONVERT TO m/s AND APPLY SEA ICE COVER 
     133          zkgo2(ji,jj) = zkgo2(ji,jj) / ( 100.*3600.)        & 
     134# if defined key_off_degrad 
     135             &        * facvol(ji,jj,1)       & 
     136# endif 
     137             &        * ( 1.- freeze(ji,jj) ) *tmask(ji,jj,1) 
     138 
     139         END DO 
    188140      END DO 
    189 C 
    190 #endif 
    191       RETURN 
    192       END 
     141 
     142      DO jj = 1, jpj 
     143         DO ji = 1, jpi 
     144 
     145            ! Compute CO2 flux for the sea and air 
     146            zfld = atcco2 * tmask(ji,jj,1) * chemc(ji,jj,3) * zkgco2(ji,jj) 
     147            zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj) 
     148            tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) / fse3t(ji,jj,1) 
     149 
     150            ! Compute O2 flux  
     151            zoxy16 = trn(ji,jj,1,jpoxy) 
     152            zflu16 = ( atcox * chemc(ji,jj,2) - zoxy16 ) * zkgo2(ji,jj) 
     153            tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy) + zflu16 / fse3t(ji,jj,1) 
     154 
     155# if defined key_trc_diaadd 
     156            ! Save diagnostics 
     157            trc2d(ji,jj,1) = ( zfld - zflu ) * 1000. 
     158            trc2d(ji,jj,2) = zflu16 * 1000. 
     159            trc2d(ji,jj,3) = zkgco2(ji,jj) 
     160            trc2d(ji,jj,4) = atcco2 - zh2co3(ji,jj) / ( chemc(ji,jj,3) + rtrn ) 
     161# endif 
     162         END DO 
     163      END DO 
     164      ! 
     165   END SUBROUTINE p4z_flx 
     166 
     167#else 
     168   !!====================================================================== 
     169   !!  Dummy module :                                   No PISCES bio-model 
     170   !!====================================================================== 
     171CONTAINS 
     172   SUBROUTINE p4z_flx( kt )                   ! Empty routine 
     173      INTEGER, INTENT( in ) ::   kt 
     174      WRITE(*,*) 'p4z_flx: You should not have seen this print! error?', kt 
     175   END SUBROUTINE p4z_flx 
     176#endif  
     177 
     178   !!====================================================================== 
     179END MODULE  p4zflx 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zint.F90

    r774 r775  
     1MODULE p4zint 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zint  *** 
     4   !! TOP :   PISCES interpolation and computation of various accessory fields 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004-03 (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_int        :  interpolation and computation of various accessory fields 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc 
     17   USE sms 
    118 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zint(kt) 
    8 #if defined key_top && defined key_pisces 
    9 CCC 
    10 CCC 
    11 CCC       ROUTINE p4zint : PISCES MODEL 
    12 CCC       ***************************** 
    13 CCC 
    14 CC 
    15 CC   PURPOSE : 
    16 CC   --------- 
    17 CC           *P4ZINT* INTERPOLATION AND COMPUTATION OF  
    18 CC                    VARIOUS ACCESSORY FIELDS 
    19 CC   INPUT : 
    20 CC   ----- 
    21 CC      argument 
    22 CC              kt              : time step 
    23 CC 
    24 CC   EXTERNAL : 
    25 CC   ---------- 
    26 CC          NONE 
    27 CC 
    28 CC   MODIFICATIONS: 
    29 CC   -------------- 
    30 CC      original      : 2004    O. Aumont 
    31 CC ---------------------------------------------------------------- 
    32 CC parameters and commons 
    33 CC ====================== 
    34 CDIR$ NOLIST 
    35       USE oce_trc 
    36       USE trp_trc 
    37       USE sms 
    38       IMPLICIT NONE 
    39 CDIR$ LIST 
    40 CC----------------------------------------------------------------- 
    41 CC------ 
    42 CC local declarations 
    43 CC ================== 
    44 C 
    45       INTEGER kt 
    46       INTEGER ji, jj 
    47       INTEGER iman 
    48       INTEGER nspyr,nvit1t,nvit2t 
    49       REAL zpdtan, zman, zpdtmo, zdemi 
    50       REAL zt, zdum 
    51 C 
    52 C 
     19   IMPLICIT NONE 
     20   PRIVATE 
     21 
     22   PUBLIC   p4z_int    ! called in p4zprg.F90 
     23 
     24   !!---------------------------------------------------------------------- 
     25   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     26   !! $Header:$  
     27   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     28   !!---------------------------------------------------------------------- 
     29 
     30CONTAINS 
     31 
     32   SUBROUTINE p4z_int( kt ) 
     33      !!--------------------------------------------------------------------- 
     34      !!                     ***  ROUTINE p4z_int  *** 
     35      !! 
     36      !! ** Purpose :   interpolation and computation of various accessory fields 
     37      !! 
     38      !! ** Method  : - ??? 
     39      !!--------------------------------------------------------------------- 
     40      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
     41      !! 
     42      INTEGER  ::   ji, jj 
     43      INTEGER  ::   iman, ivit1t, ivit2t 
     44      REAL(wp) ::   zpdtan, zman, zpdtmo, zdemi 
     45      REAL(wp) ::   zt, zdum 
     46      !!--------------------------------------------------------------------- 
     47 
    5348      zpdtan = raass / rdt 
    54       nspyr  = nint(zpdtan) 
    5549      zman   = 12. 
    5650      iman   = 12 
    … …  
    5953      zt     = ( float ( kt) + zdemi) / zpdtmo 
    6054       
    61 C  recherche de l'indice des enregistrements 
    62 C  du modele dynamique encadrant le pas de temps kt. 
    63 C  -------------------------------------------------- 
    64 C 
    65       xtvit = zt - float(int ( zt)) 
    66       nvit1t = int (zt) 
    67       nvit2t = nvit1t+1 
    68       nvit1t = MOD ( nvit1t, iman) 
    69       IF ( nvit1t .EQ. 0 ) nvit1t = iman 
    70       nvit2t = MOD ( nvit2t, iman) 
    71       IF ( nvit2t .EQ. 0 ) nvit2t = iman 
    72 C 
    73 C Interpolation of dust deposition 
    74 C -------------------------------- 
    75 C 
    76          dust(:,:) = (1.-xtvit)*dustmo(:,:,nvit1t) 
    77      $            +xtvit*dustmo(:,:,nvit2t) 
    78 C 
    79 C 
    80 C Computation of phyto and zoo metabolic rate 
    81 C ------------------------------------------- 
    82 C 
     55      !  recherche de l indice des enregistrements 
     56      !  du modele dynamique encadrant le pas de temps kt. 
     57      !  -------------------------------------------------- 
    8358 
    84          Tgfunc(:,:,:) = exp(0.063913*tn(:,:,:)) 
    85          Tgfunc2(:,:,:) = exp(0.07608*tn(:,:,:)) 
    86 C 
    87 C      Computation of the silicon dependant half saturation 
    88 C      constant for silica uptake 
    89 C       --------------------------------------------------- 
    90 C 
    91         DO ji=1,jpi 
    92           DO jj=1,jpj 
    93           zdum=trn(ji,jj,1,jpsil)**2 
    94           xksimax(ji,jj) = max(xksimax(ji,jj),(1.+7.*zdum 
    95      &      /(xksi2*xksi2*25.+zdum))*1E-6) 
    96           END DO 
    97         END DO 
    98 C 
    99         IF (nday_year.EQ.365) THEN 
    100            xksi=xksimax 
    101            xksimax=0. 
    102         ENDIF 
    103 C 
    104 #endif 
    105 C 
    106       RETURN 
    107       END 
     59      xtvit = zt - FLOAT( INT( zt ) ) 
     60      ivit1t = INT( zt ) 
     61      ivit2t = ivit1t + 1 
     62      ivit1t = MOD ( ivit1t, iman ) 
     63      IF( ivit1t == 0 )   ivit1t = iman 
     64      ivit2t = MOD ( ivit2t, iman ) 
     65      IF( ivit2t == 0 )   ivit2t = iman 
     66 
     67      ! Interpolation of dust deposition 
     68      ! -------------------------------- 
     69 
     70      dust(:,:) = ( 1.- xtvit ) * dustmo(:,:,ivit1t) + xtvit * dustmo(:,:,ivit2t) 
     71 
     72      ! Computation of phyto and zoo metabolic rate 
     73      ! ------------------------------------------- 
     74 
     75      Tgfunc (:,:,:) = EXP( 0.063913 * tn(:,:,:) ) 
     76      Tgfunc2(:,:,:) = EXP( 0.07608  * tn(:,:,:) ) 
     77 
     78      ! Computation of the silicon dependant half saturation 
     79      ! constant for silica uptake 
     80      ! --------------------------------------------------- 
     81 
     82      DO ji = 1, jpi 
     83         DO jj = 1, jpj 
     84            zdum = trn(ji,jj,1,jpsil) * trn(ji,jj,1,jpsil) 
     85            xksimax(ji,jj) = MAX( xksimax(ji,jj), ( 1.+ 7.* zdum / ( xksi2 * xksi2 * 25. + zdum ) ) * 1e-6 ) 
     86         END DO 
     87      END DO 
     88 
     89      IF( nday_year == 365 ) THEN 
     90         xksi    = xksimax 
     91         xksimax = 0.e0 
     92      ENDIF 
     93      ! 
     94   END SUBROUTINE p4z_int 
     95 
     96#else 
     97   !!====================================================================== 
     98   !!  Dummy module :                                   No PISCES bio-model 
     99   !!====================================================================== 
     100CONTAINS 
     101   SUBROUTINE p4z_int( kt )                   ! Empty routine 
     102      INTEGER, INTENT( in ) ::   kt 
     103      WRITE(*,*) 'p4z_int: You should not have seen this print! error?', kt 
     104   END SUBROUTINE p4z_int 
     105#endif  
     106 
     107   !!====================================================================== 
     108END MODULE  p4zint 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zlim.F90

    r774 r775  
     1MODULE p4zlim 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zlim  *** 
     4   !! TOP :   PISCES  
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_lim        :   
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc         !  
     17   USE sms             !  
    118 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zlim 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC             ROUTINE p4zlim : PISCES MODEL 
    12 CCC             ***************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the co-limitations by the various nutrients 
    17 CCC         for the various phytoplankton species 
    18 CCC 
    19 CC   INPUT : 
    20 CC   ----- 
    21 CC      argument 
    22 CC              None 
    23 CC      common 
    24 CC              all the common defined in opa 
    25 CC 
    26 CC 
    27 CC   OUTPUT :                   : no 
    28 CC   ------ 
    29 CC 
    30 CC   MODIFICATIONS: 
    31 CC   -------------- 
    32 CC      original  : O. Aumont (2004) 
    33 CC---------------------------------------------------------------------- 
    34 CC parameters and commons 
    35 CC ====================== 
    36 CDIR$ NOLIST 
    37       USE oce_trc 
    38       USE trp_trc 
    39       USE sms 
    40       IMPLICIT NONE 
    41 #include "domzgr_substitute.h90" 
    42 CDIR$ LIST 
    43 CC---------------------------------------------------------------------- 
    44 CC local declarations 
    45 CC ================== 
    46       INTEGER ji, jj, jk 
    47       REAL xlim1,xlim2,xlim3,xlim4,zno3,zferlim 
    48       REAL xconctemp,xconctemp2,xconctempn,xconctempn2 
    49 C 
    50 C  Tuning of the iron concentration to a minimum 
    51 C  level that is set to the detection limit 
    52 C  ------------------------------------- 
    53 C 
    54         do jk=1,jpk 
    55           do jj=1,jpj 
    56             do ji=1,jpi 
    57         zno3=trn(ji,jj,jk,jpno3)*1E6 
    58         zferlim=max(1.5E-11*(zno3/40)**2,3E-12) 
    59         zferlim=min(zferlim,1.5E-11) 
    60         trn(ji,jj,jk,jpfer)=max(trn(ji,jj,jk,jpfer),zferlim) 
    61             end do 
    62           end do 
    63         end do 
    64 C 
    65 C  Computation of a variable Ks for iron on diatoms 
    66 C  taking into account that increasing biomass is 
    67 C  made of generally bigger cells 
    68 C  ------------------------------------------------ 
    69 C 
    70         DO jk=1,jpkm1 
    71           DO jj=1,jpj 
    72             DO ji=1,jpi 
    73         xconctemp=max(0.,trn(ji,jj,jk,jpdia)-5E-7) 
    74         xconctemp2=min(5.E-7,trn(ji,jj,jk,jpdia)) 
    75         xconctempn=max(0.,trn(ji,jj,jk,jpphy)-1E-6) 
    76         xconctempn2=min(1.E-6,trn(ji,jj,jk,jpphy)) 
    77         concdfe(ji,jj,jk)=(xconctemp2*conc3+0.4E-9* 
    78      .    xconctemp)/(xconctemp2+xconctemp+rtrn) 
    79         concdfe(ji,jj,jk)=max(conc3,concdfe(ji,jj,jk)) 
    80         concnfe(ji,jj,jk)=(xconctempn2*conc2+0.08E-9* 
    81      .    xconctempn)/(xconctempn2+xconctempn+rtrn) 
    82         concnfe(ji,jj,jk)=max(conc2,concnfe(ji,jj,jk)) 
     19   IMPLICIT NONE 
     20   PRIVATE 
     21 
     22   PUBLIC   p4z_lim    ! called in p4zprg.F90 
     23 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
     31 
     32CONTAINS 
     33 
     34   SUBROUTINE p4z_lim 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_lim  *** 
     37      !! 
     38      !! ** Purpose :   Compute the co-limitations by the various nutrients 
     39      !!              for the various phytoplankton species 
     40      !! 
     41      !! ** Method  : - ??? 
     42      !!--------------------------------------------------------------------- 
     43      INTEGER  ::   ji, jj, jk 
     44      REAL(wp) ::   zlim1, zlim2, zlim3, zlim4, zno3, zferlim 
     45      REAL(wp) ::   zconctemp, zconctemp2, zconctempn, zconctempn2 
     46      !!--------------------------------------------------------------------- 
     47 
     48!  Tuning of the iron concentration to a minimum 
     49!  level that is set to the detection limit 
     50!  ------------------------------------- 
     51 
     52      DO jk = 1, jpk 
     53         DO jj = 1, jpj 
     54            DO ji = 1, jpi 
     55               zno3   = trn(ji,jj,jk,jpno3) * 1.e6 
     56               zferlim = MAX( 1.5e-11*(zno3/40)**2, 3e-12 ) 
     57               zferlim = MIN( zferlim, 1.5e-11 ) 
     58               trn(ji,jj,jk,jpfer) = MAX( trn(ji,jj,jk,jpfer), zferlim ) 
    8359            END DO 
    84           END DO 
    85         END DO 
    86 C 
    87         DO jk = 1,jpkm1 
    88           DO jj = 1,jpj 
    89             DO ji = 1,jpi 
    90 C     
    91 C      Michaelis-Menten Limitation term for nutrients 
    92 C      Small flagellates 
    93 C      ----------------------------------------------- 
    94 C 
    95         xnanono3(ji,jj,jk)=trn(ji,jj,jk,jpno3)*concnnh4 
    96      &      /(conc0*concnnh4+concnnh4*trn(ji,jj,jk,jpno3)+ 
    97      &        conc0*trn(ji,jj,jk,jpnh4)) 
    98         xnanonh4(ji,jj,jk)=trn(ji,jj,jk,jpnh4)*conc0 
    99      &      /(conc0*concnnh4+concnnh4*trn(ji,jj,jk,jpno3)+ 
    100      &        conc0*trn(ji,jj,jk,jpnh4)) 
    101         xlim1=xnanono3(ji,jj,jk)+xnanonh4(ji,jj,jk) 
    102         xlim2=trn(ji,jj,jk,jppo4)/(trn(ji,jj,jk,jppo4)+concnnh4) 
    103         xlim3=trn(ji,jj,jk,jpfer)/(trn(ji,jj,jk,jpfer) 
    104      &     +concnfe(ji,jj,jk)) 
    105         xlimphy(ji,jj,jk)=min(xlim1,xlim2,xlim3) 
    106         xlim1=trn(ji,jj,jk,jpnh4)/(concnnh4+trn(ji,jj,jk,jpnh4)) 
    107         xlim3=trn(ji,jj,jk,jpfer)/(trn(ji,jj,jk,jpfer)+conc2) 
    108         xlim4=trn(ji,jj,jk,jpdoc)/(trn(ji,jj,jk,jpdoc)+xkdoc2) 
    109         xlimbac(ji,jj,jk)=min(xlim1,xlim2,xlim3)*xlim4 
    110 C 
     60         END DO 
     61      END DO 
     62 
     63!  Computation of a variable Ks for iron on diatoms 
     64!  taking into account that increasing biomass is 
     65!  made of generally bigger cells 
     66!  ------------------------------------------------ 
     67 
     68      DO jk = 1, jpkm1 
     69         DO jj = 1, jpj 
     70            DO ji = 1, jpi 
     71               zconctemp   = MAX( 0.e0 , trn(ji,jj,jk,jpdia)-5e-7 ) 
     72               zconctemp2  = MIN( 5.e-7, trn(ji,jj,jk,jpdia)      ) 
     73               zconctempn  = MAX( 0.e0 , trn(ji,jj,jk,jpphy)-1e-6 ) 
     74               zconctempn2 = MIN( 1.e-6, trn(ji,jj,jk,jpphy)      ) 
     75               concdfe(ji,jj,jk) = ( zconctemp2 * conc3 + 0.4e-9 * zconctemp)   & 
     76                  &              / ( zconctemp2 + zconctemp + rtrn ) 
     77               concdfe(ji,jj,jk) = MAX( conc3, concdfe(ji,jj,jk) ) 
     78               concnfe(ji,jj,jk) = ( zconctempn2 * conc2 + 0.08e-9 * zconctempn)   & 
     79                  &              / ( zconctempn2 + zconctempn + rtrn ) 
     80               concnfe(ji,jj,jk) = MAX( conc2, concnfe(ji,jj,jk) ) 
    11181            END DO 
    112           END DO 
    113         END DO 
    114 C 
    115         DO jk = 1,jpkm1 
    116           DO jj = 1,jpj 
    117             DO ji = 1,jpi 
    118 C 
    119 C   Michaelis-Menten Limitation term for nutrients 
    120 C   Diatoms 
    121 C   ---------------------------------------------- 
    122 C 
    123         xdiatno3(ji,jj,jk)=trn(ji,jj,jk,jpno3)*concdnh4 
    124      &      /(conc1*concdnh4+concdnh4*trn(ji,jj,jk,jpno3)+ 
    125      &        conc1*trn(ji,jj,jk,jpnh4)) 
    126         xdiatnh4(ji,jj,jk)=trn(ji,jj,jk,jpnh4)*conc1 
    127      &      /(conc1*concdnh4+concdnh4*trn(ji,jj,jk,jpno3)+ 
    128      &        conc1*trn(ji,jj,jk,jpnh4)) 
     82         END DO 
     83      END DO 
    12984 
    130         xlim1=xdiatno3(ji,jj,jk)+xdiatnh4(ji,jj,jk) 
    131         xlim2=trn(ji,jj,jk,jppo4)/(trn(ji,jj,jk,jppo4)+concdnh4) 
    132         xlim3=trn(ji,jj,jk,jpsil)/(trn(ji,jj,jk,jpsil)+xksi(ji,jj)) 
    133         xlim4=trn(ji,jj,jk,jpfer)/(trn(ji,jj,jk,jpfer) 
    134      &      +concdfe(ji,jj,jk)) 
    135         xlimdia(ji,jj,jk)=min(xlim1,xlim2,xlim3,xlim4) 
    136 C 
     85      DO jk = 1, jpkm1 
     86         DO jj = 1, jpj 
     87            DO ji = 1, jpi 
     88     
     89!      Michaelis-Menten Limitation term for nutrients 
     90!      Small flagellates 
     91!      ----------------------------------------------- 
     92 
     93               xnanono3(ji,jj,jk) = trn(ji,jj,jk,jpno3) * concnnh4           & 
     94                  &               / ( conc0 * concnnh4 + concnnh4 * trn(ji,jj,jk,jpno3)   & 
     95                  &                                    + conc0    * trn(ji,jj,jk,jpnh4) ) 
     96               xnanonh4(ji,jj,jk) = trn(ji,jj,jk,jpnh4) * conc0              & 
     97                  &               / ( conc0 * concnnh4 + concnnh4 * trn(ji,jj,jk,jpno3)   & 
     98                  &                                    + conc0    * trn(ji,jj,jk,jpnh4) ) 
     99               zlim1 = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) 
     100               zlim2 = trn(ji,jj,jk,jppo4) / ( trn(ji,jj,jk,jppo4) + concnnh4          )  
     101               zlim3 = trn(ji,jj,jk,jpfer) / ( trn(ji,jj,jk,jpfer) + concnfe(ji,jj,jk) ) 
     102               xlimphy(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) 
     103               zlim1 = trn(ji,jj,jk,jpnh4) / ( concnnh4 + trn(ji,jj,jk,jpnh4) ) 
     104               zlim3 = trn(ji,jj,jk,jpfer) / ( conc2    + trn(ji,jj,jk,jpfer) ) 
     105               zlim4 = trn(ji,jj,jk,jpdoc) / ( xkdoc2   + trn(ji,jj,jk,jpdoc) ) 
     106               xlimbac(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) * zlim4 
     107 
    137108            END DO 
    138           END DO 
    139         END DO 
    140 C 
    141 #endif 
    142       RETURN 
    143       END 
     109         END DO 
     110      END DO 
     111 
     112      DO jk = 1, jpkm1 
     113         DO jj = 1, jpj 
     114            DO ji = 1, jpi 
     115 
     116!   Michaelis-Menten Limitation term for nutrients Diatoms 
     117!   ---------------------------------------------- 
     118 
     119               xdiatno3(ji,jj,jk) = trn(ji,jj,jk,jpno3) * concdnh4                         & 
     120                  &               / ( conc1  * concdnh4 + concdnh4 * trn(ji,jj,jk,jpno3)   & 
     121                  &                                     + conc1    * trn(ji,jj,jk,jpnh4) ) 
     122               xdiatnh4(ji,jj,jk) = trn(ji,jj,jk,jpnh4) * conc1                            & 
     123                  &               / ( conc1  * concdnh4 + concdnh4 * trn(ji,jj,jk,jpno3)   & 
     124                  &                                     + conc1   * trn(ji,jj,jk,jpnh4) ) 
     125 
     126               zlim1 = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) 
     127               zlim2 = trn(ji,jj,jk,jppo4) / ( trn(ji,jj,jk,jppo4) + concdnh4          ) 
     128               zlim3 = trn(ji,jj,jk,jpsil) / ( trn(ji,jj,jk,jpsil) + xksi   (ji,jj)    ) 
     129               zlim4 = trn(ji,jj,jk,jpfer) / ( trn(ji,jj,jk,jpfer) + concdfe(ji,jj,jk) ) 
     130               xlimdia(ji,jj,jk) = MIN( zlim1, zlim2, zlim3, zlim4 ) 
     131 
     132            END DO 
     133         END DO 
     134      END DO 
     135      ! 
     136   END SUBROUTINE p4z_lim 
     137 
     138#else 
     139   !!====================================================================== 
     140   !!  Dummy module :                                   No PISCES bio-model 
     141   !!====================================================================== 
     142CONTAINS 
     143   SUBROUTINE p4z_lim                   ! Empty routine 
     144   END SUBROUTINE p4z_lim 
     145#endif  
     146 
     147   !!====================================================================== 
     148END MODULE  p4zlim 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zlys.F90

    r774 r775  
     1MODULE p4zlys 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zlys  *** 
     4   !! TOP :   PISCES  
     5   !!====================================================================== 
     6   !! History :    -   !  1988-07  (E. MAIER-REIMER) Original code 
     7   !!              -   !  1998     (O. Aumont) additions 
     8   !!              -   !  1999     (C. Le Quere) modifications 
     9   !!             1.0  !  2004     (O. Aumont) modifications 
     10   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     11   !!---------------------------------------------------------------------- 
     12#if defined key_pisces 
     13   !!---------------------------------------------------------------------- 
     14   !!   'key_pisces'                                       PISCES bio-model 
     15   !!---------------------------------------------------------------------- 
     16   !!   p4z_lys        :   
     17   !!---------------------------------------------------------------------- 
     18   USE oce_trc         ! 
     19   USE trp_trc 
     20   USE sms 
    121 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7        SUBROUTINE p4zlys 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC        ROUTINE p4zlys : PISCES MODEL 
    12 CCC        ***************************** 
    13 CCC 
    14 CCC 
    15 CCC     PURPOSE. 
    16 CCC     -------- 
    17 CCC          *P4ZLYS*  CALCULATES DEGREE OF CACO3 SATURATION IN THE WATER 
    18 CCC                    COLUMN, DISSOLUTION/PRECIPITATION OF CACO3 AND LOSS 
    19 CCC                    OF CACO3 TO THE CACO3 SEDIMENT POOL. 
    20 CC 
    21 CC     EXTERNALS. 
    22 CC     ---------- 
    23 CC          NONE. 
    24 CC 
    25 CC   MODIFICATIONS: 
    26 CC   -------------- 
    27 CC      original      : 1988-07 E. MAIER-REIMER      MPI HAMBURG 
    28 CC      additions     : 1998    O. Aumont 
    29 CC      modifications : 1999    C. Le Quere 
    30 CC      modifications : 2004    O. Aumont 
    31 CC --------------------------------------------------------------------------- 
    32 CC parameters and commons 
    33 CC ====================== 
    34 CDIR$ NOLIST 
    35       USE oce_trc 
    36       USE trp_trc 
    37       USE sms 
    38       IMPLICIT NONE 
    39 CDIR$ LIST 
    40 CC---------------------------------------------------------------------- 
    41 CC local declarations 
    42 CC ================== 
    43 C 
    44       INTEGER ji, jj, jk, jn 
    45       REAL zbot, zalk, zdic, zph, remco3, ah2 
    46       REAL dispot, zfact, zalka 
    47       REAL omegaca, excess, excess0 
    48       REAL co3(jpi,jpj,jpk) 
    49 C 
    50 C 
    51 C* 1.1  BEGIN OF ITERATION 
    52 C ------------------------ 
    53 C 
    54       DO jn = 1,5 
    55 C 
    56 C* 1.2  COMPUTE [CO3--] and [H+] CONCENTRATIONS 
    57 C ------------------------------------------- 
    58 C 
    59       DO jk = 1,jpkm1 
    60         DO jj=1,jpj 
    61           DO ji = 1, jpi 
    62 C 
    63 C* 1.3  SET DUMMY VARIABLE FOR TOTAL BORATE 
    64 C ----------------------------------------- 
    65 C 
    66         zbot = borat(ji,jj,jk) 
    67         zfact=rhop(ji,jj,jk)/1000.+rtrn 
    68 C 
    69 C* 1.4  SET DUMMY VARIABLE FOR [H+] 
    70 C --------------------------------- 
    71 C 
    72         zph = hi(ji,jj,jk)*tmask(ji,jj,jk)/zfact 
    73      &    +(1.-tmask(ji,jj,jk))*1.e-9 
    74 C 
    75 C* 1.5  SET DUMMY VARIABLE FOR [SUM(CO2)]GIVEN  
    76 C ------------------------------------------- 
    77 C 
    78         zdic=trn(ji,jj,jk,jpdic)/zfact 
    79         zalka=trn(ji,jj,jk,jptal)/zfact 
    80 C 
    81 C* 1.6 CALCULATE [ALK]([CO3--], [HCO3-]) 
    82 C ------------------------------------ 
    83 C 
    84         zalk=zalka-(akw3(ji,jj,jk)/zph-zph 
    85      &     +zbot/(1.+zph/akb3(ji,jj,jk))) 
    86 C 
    87 C* 2.10 CALCULATE [H+] and [CO3--] 
    88 C ----------------------------------------- 
    89 C 
    90         ah2=sqrt((zdic-zalk)*(zdic-zalk)+ 
    91      &     4.*(zalk*ak23(ji,jj,jk)/ak13(ji,jj,jk)) 
    92      &     *(2*zdic-zalk)) 
    93 C 
    94         ah2=0.5*ak13(ji,jj,jk)/zalk*((zdic-zalk)+ah2) 
    95         co3(ji,jj,jk) = zalk/(2.+ah2/ak23(ji,jj,jk))*zfact 
     22   IMPLICIT NONE 
     23   PRIVATE 
    9624 
    97         hi(ji,jj,jk)  = ah2*zfact 
    98 C 
    99           ENDDO 
    100         ENDDO 
    101       END DO 
    102 C 
     25   PUBLIC   p4z_lys    ! called in p4zprg.F90 
     26 
     27   !!---------------------------------------------------------------------- 
     28   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     29   !! $Header:$  
     30   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     31   !!---------------------------------------------------------------------- 
     32 
     33CONTAINS 
     34 
     35   SUBROUTINE p4z_lys 
     36      !!--------------------------------------------------------------------- 
     37      !!                     ***  ROUTINE p4z_lys  *** 
     38      !! 
     39      !! ** Purpose :   CALCULATES DEGREE OF CACO3 SATURATION IN THE WATER 
     40      !!              COLUMN, DISSOLUTION/PRECIPITATION OF CACO3 AND LOSS 
     41      !!              OF CACO3 TO THE CACO3 SEDIMENT POOL. 
     42      !! 
     43      !! ** Method  : - ??? 
     44      !!--------------------------------------------------------------------- 
     45      INTEGER  ::   ji, jj, jk, jn 
     46      REAL(wp) ::   zbot, zalk, zdic, zph, zremco3, zah2 
     47      REAL(wp) ::   zdispot, zfact, zalka 
     48      REAL(wp) ::   zomegaca, zexcess, zexcess0 
     49      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zco3 
     50      !!--------------------------------------------------------------------- 
     51 
     52 
     53      !     ------------------------------------------- 
     54      !     COMPUTE [CO3--] and [H+] CONCENTRATIONS 
     55      !     ------------------------------------------- 
     56       
     57      DO jn = 1, 5                               !  BEGIN OF ITERATION 
     58         ! 
     59         DO jk = 1, jpkm1 
     60            DO jj = 1, jpj 
     61               DO ji = 1, jpi 
     62 
     63                  ! SET DUMMY VARIABLE FOR TOTAL BORATE 
     64                  zbot  = borat(ji,jj,jk) 
     65                  zfact = rhop (ji,jj,jk) / 1000. + rtrn 
     66 
     67                  ! SET DUMMY VARIABLE FOR [H+] 
     68                  zph   = hi(ji,jj,jk) * tmask(ji,jj,jk) / zfact + ( 1.-tmask(ji,jj,jk) ) * 1.e-9 
     69 
     70                  ! SET DUMMY VARIABLE FOR [SUM(CO2)]GIVEN  
     71                  zdic  = trn(ji,jj,jk,jpdic) / zfact 
     72                  zalka = trn(ji,jj,jk,jptal) / zfact 
     73 
     74                  ! CALCULATE [ALK]([CO3--], [HCO3-]) 
     75                  zalk  = zalka - (  akw3(ji,jj,jk) / zph - zph   & 
     76                     &             + zbot / (1.+ zph / akb3(ji,jj,jk) )  ) 
     77 
     78                  ! CALCULATE [H+] and [CO3--] 
     79                  zah2 = SQRT( (zdic-zalk)*(zdic-zalk)+   & 
     80                     &     4.*(zalk*ak23(ji,jj,jk)/ak13(ji,jj,jk))   & 
     81                     &     *(2*zdic-zalk)) 
     82 
     83                  zah2=0.5*ak13(ji,jj,jk)/zalk*((zdic-zalk)+zah2) 
     84                  zco3(ji,jj,jk) = zalk/(2.+zah2/ak23(ji,jj,jk))*zfact 
     85 
     86                  hi(ji,jj,jk)  = zah2*zfact 
     87 
     88               END DO 
     89            END DO 
     90         END DO 
     91         ! 
    10392      END DO  
    104 C 
    105 C     --------------------------------------------------------- 
    106 C*    2. CALCULATE DEGREE OF CACO3 SATURATION AND CORRESPONDING 
    107 C        DISSOLOUTION AND PRECIPITATION OF CACO3 (BE AWARE OF 
    108 C        MGCO3) 
    109 C     --------------------------------------------------------- 
    110 C 
    111       DO jk = 1,jpkm1 
    112         DO jj = 1,jpj 
    113           DO ji = 1, jpi 
    114 C 
    115 C* 2.1  DEVIATION OF [CO3--] FROM SATURATION VALUE 
    116 C ------------------------------------------------ 
    117 C 
    118             omegaca = ( calcon * co3(ji,jj,jk) )/aksp(ji,jj,jk) 
    11993 
    120 C 
    121 C* 2.2  SET DEGREE OF UNDER-/SUPERSATURATION 
    122 C ------------------------------------------ 
    123 C 
    124             excess0 = max(0.,(1.-omegaca)) 
    125             excess = excess0**nca 
     94      !     --------------------------------------------------------- 
     95      !        CALCULATE DEGREE OF CACO3 SATURATION AND CORRESPONDING 
     96      !        DISSOLOUTION AND PRECIPITATION OF CACO3 (BE AWARE OF 
     97      !        MGCO3) 
     98      !     --------------------------------------------------------- 
    12699 
    127 C 
    128 C* 2.3  AMOUNT CACO3 (12C) THAT RE-ENTERS SOLUTION 
    129 C       (ACCORDING TO THIS FORMULATION ALSO SOME PARTICULATE 
    130 C       CACO3 GETS DISSOLVED EVEN IN THE CASE OF OVERSATURATION) 
    131 C -------------------------------------------------------------- 
    132 C 
    133             dispot = kdca * excess * trn(ji,jj,jk,jpcal) 
    134 #    if defined key_off_degrad 
    135      &        *facvol(ji,jj,jk) 
    136 #    endif 
     100      DO jk = 1, jpkm1 
     101         DO jj = 1, jpj 
     102            DO ji = 1, jpi 
    137103 
    138 C 
    139 C* 2.4  CHANGE OF [CO3--] , [ALK], PARTICULATE [CACO3], 
    140 C       AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION 
    141 C ----------------------------------------------------------- 
    142 C 
    143             remco3=dispot/rmoss 
    144             co3(ji,jj,jk) = co3(ji,jj,jk)+ 
    145      &        remco3*rfact 
    146             tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal)+ 
    147      &        2.*remco3 
    148             tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal)- 
    149      &        remco3 
    150             tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic)+ 
    151      &        remco3 
    152 C 
    153           ENDDO 
    154         ENDDO 
     104               ! DEVIATION OF [CO3--] FROM SATURATION VALUE 
     105               zomegaca = ( calcon * zco3(ji,jj,jk) ) / aksp(ji,jj,jk) 
     106 
     107               ! SET DEGREE OF UNDER-/SUPERSATURATION 
     108               zexcess0 = MAX( 0., ( 1.- zomegaca ) ) 
     109               zexcess  = zexcess0**nca 
     110 
     111               ! AMOUNT CACO3 (12C) THAT RE-ENTERS SOLUTION 
     112               !       (ACCORDING TO THIS FORMULATION ALSO SOME PARTICULATE 
     113               !       CACO3 GETS DISSOLVED EVEN IN THE CASE OF OVERSATURATION) 
     114# if defined key_off_degrad 
     115              zdispot = kdca * zexcess * trn(ji,jj,jk,jpcal) * facvol(ji,jj,jk) 
     116# else 
     117              zdispot = kdca * zexcess * trn(ji,jj,jk,jpcal) 
     118# endif 
     119 
     120              !  CHANGE OF [CO3--] , [ALK], PARTICULATE [CACO3], 
     121              !       AND [SUM(CO2)] DUE TO CACO3 DISSOLUTION/PRECIPITATION 
     122              zremco3 = zdispot / rmoss 
     123              zco3(ji,jj,jk) = zco3(ji,jj,jk) + zremco3 * rfact 
     124              tra(ji,jj,jk,jptal) = tra(ji,jj,jk,jptal) + 2.*zremco3 
     125              tra(ji,jj,jk,jpcal) = tra(ji,jj,jk,jpcal) -    zremco3 
     126              tra(ji,jj,jk,jpdic) = tra(ji,jj,jk,jpdic) +    zremco3 
     127 
     128            END DO 
     129         END DO 
    155130      END DO 
    156131 
    157 #    if defined key_trc_dia3d 
     132# if defined key_trc_dia3d 
    158133         trc3d(:,:,:,1) = rhop(:,:,:) 
    159          trc3d(:,:,:,2) = co3(:,:,:) 
    160          trc3d(:,:,:,3) = aksp(:,:,:)/calcon 
    161 #    endif 
     134         trc3d(:,:,:,2) = zco3(:,:,:) 
     135         trc3d(:,:,:,3) = aksp(:,:,:) / calcon 
     136# endif 
     137      ! 
     138   END SUBROUTINE p4z_lys 
    162139 
    163 C 
    164 #endif 
    165       RETURN 
    166       END 
     140#else 
     141   !!====================================================================== 
     142   !!  Dummy module :                                   No PISCES bio-model 
     143   !!====================================================================== 
     144CONTAINS 
     145   SUBROUTINE p4z_lys( kt )                   ! Empty routine 
     146      INTEGER, INTENT( in ) ::   kt 
     147      WRITE(*,*) 'p4z_lys: You should not have seen this print! error?', kt 
     148   END SUBROUTINE p4z_lys 
     149#endif  
     150 
     151   !!====================================================================== 
     152END MODULE  p4zlys 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zmeso.F90

    r774 r775  
    1  
    2 CCC $Header: /home/opalod/NEMOCVSROOT/NEMO/TOP_SRC/SMS/p4zmeso.F,v 1.8 2007/10/12 09:32:52 opalod Exp $  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zmeso 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC            ROUTINE p4zmeso : PISCES MODEL 
    12 CCC            ****************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the sources/sinks for mesozooplankton 
    17 CCC 
    18 CC   METHOD : 
    19 CC   ------- 
    20 CC       
    21 CC 
    22 CC   INPUT : 
    23 CC   ----- 
    24 CC      argument 
    25 CC              None 
    26 CC      common 
    27 CC              all the common defined in opa 
    28 CC 
    29 CC 
    30 CC   OUTPUT :                   : no 
    31 CC   ------ 
    32 CC 
    33 CC   EXTERNAL : 
    34 CC   -------- 
    35 CC          None 
    36 CC 
    37 CC   MODIFICATIONS: 
    38 CC   -------------- 
    39 CC      original  : O. Aumont (2002) 
    40 CC---------------------------------------------------------------------- 
    41 CC parameters and commons 
    42 CC ====================== 
    43 CDIR$ NOLIST 
    44       USE oce_trc 
    45       USE trp_trc 
    46       USE sms 
    47       IMPLICIT NONE 
    48 CDIR$ LIST 
    49 CC---------------------------------------------------------------------- 
    50 CC local declarations 
    51 CC ================== 
    52       INTEGER ji, jj, jk 
    53       REAL compadi,compaph,compapoc,compaz 
    54       REAL zfact,zstep,compam,zdenom,graze2 
    55 C 
    56 C 
    57 C 
    58 C     Time step duration for biology 
    59 C     ------------------------------ 
    60 C 
    61         zstep=rfact2/rjjss 
    62 C 
    63         DO jk = 1,jpkm1 
    64           DO jj = 1,jpj 
    65             DO ji = 1,jpi 
    66 C 
    67         compam=max((trn(ji,jj,jk,jpmes)-1.E-9),0.) 
    68         zfact=zstep*tgfunc(ji,jj,jk)*compam 
    69 #    if defined key_off_degrad 
    70      &    *facvol(ji,jj,jk) 
    71 #    endif 
    72 C 
    73 C     Respiration rates of both zooplankton 
    74 C     ------------------------------------- 
    75 C 
    76         respz2(ji,jj,jk) = resrat2*zfact 
    77      &    *(1.+3.*nitrfac(ji,jj,jk)) 
    78      &    *trn(ji,jj,jk,jpmes)/(xkmort+trn(ji,jj,jk,jpmes)) 
    79 C 
    80 C     Zooplankton mortality. A square function has been selected with 
    81 C     no real reason except that it seems to be more stable and may 
    82 C     mimic predation. 
    83 C     --------------------------------------------------------------- 
    84 C 
    85         tortz2(ji,jj,jk) = mzrat2*1E6*zfact*trn(ji,jj,jk,jpmes) 
    86 C 
    87             END DO 
    88           END DO 
    89         END DO 
    90  
    91         DO jk = 1,jpkm1 
    92           DO jj = 1,jpj 
    93             DO ji = 1,jpi 
    94 C 
    95         compadi = max((trn(ji,jj,jk,jpdia)-1E-8),0.) 
    96         compaz = max((trn(ji,jj,jk,jpzoo)-1.E-8),0.) 
    97         compaph = max((trn(ji,jj,jk,jpphy)-2E-7),0.) 
    98         compapoc=max((trn(ji,jj,jk,jppoc)-1E-8),0.) 
    99 C 
    100 C     Microzooplankton grazing 
    101 C     ------------------------ 
    102 C 
    103         zdenom=1./(xkgraz2+xprefc*trn(ji,jj,jk,jpdia) 
    104      &    +xprefz*trn(ji,jj,jk,jpzoo) 
    105      &    +xprefp*trn(ji,jj,jk,jpphy) 
    106      &    +xprefpoc*trn(ji,jj,jk,jppoc)) 
    107  
    108         graze2 = grazrat2*zstep*Tgfunc2(ji,jj,jk)*zdenom 
    109      &    *trn(ji,jj,jk,jpmes) 
    110 #    if defined key_off_degrad 
    111      &    *facvol(ji,jj,jk) 
    112 #    endif 
    113  
    114         grazd(ji,jj,jk) = graze2*xprefc*compadi 
    115         grazz(ji,jj,jk) = graze2*xprefz*compaz 
    116         grazn(ji,jj,jk) = graze2*xprefp*compaph 
    117         grazpoc(ji,jj,jk) = graze2*xprefpoc*compapoc 
    118  
    119         graznf(ji,jj,jk) = grazn(ji,jj,jk) 
    120      &    *trn(ji,jj,jk,jpnfe)/(trn(ji,jj,jk,jpphy)+rtrn) 
    121  
    122         graznch(ji,jj,jk) = grazn(ji,jj,jk) 
    123      &    *trn(ji,jj,jk,jpnch)/(trn(ji,jj,jk,jpphy)+rtrn) 
    124  
    125         grazs(ji,jj,jk) = grazd(ji,jj,jk) 
    126      &    *trn(ji,jj,jk,jpbsi)/(trn(ji,jj,jk,jpdia)+rtrn) 
    127  
    128         grazf(ji,jj,jk) = grazd(ji,jj,jk) 
    129      &    *trn(ji,jj,jk,jpdfe)/(trn(ji,jj,jk,jpdia)+rtrn) 
    130  
    131         grazdch(ji,jj,jk) = grazd(ji,jj,jk) 
    132      &    *trn(ji,jj,jk,jpdch)/(trn(ji,jj,jk,jpdia)+rtrn) 
    133  
    134         grazpof(ji,jj,jk) = grazpoc(ji,jj,jk) 
    135      &    *trn(ji,jj,jk,jpsfe)/(trn(ji,jj,jk,jppoc)+rtrn) 
    136 C 
    137             END DO 
    138           END DO 
    139         END DO 
    140  
    141         DO jk = 1,jpkm1 
    142           DO jj = 1,jpj 
    143             DO ji = 1,jpi 
    144 C 
    145 C    Mesozooplankton flux feeding on GOC 
    146 C    ---------------------------------- 
    147 C 
     1MODULE p4zmeso 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zmeso  *** 
     4   !! TOP :   PISCES Compute the sources/sinks for mesozooplankton 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2002     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_meso       :   Compute the sources/sinks for mesozooplankton 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc         !  
     17   USE sms             !  
     18 
     19   IMPLICIT NONE 
     20   PRIVATE 
     21 
     22   PUBLIC   p4z_meso    ! called in p4zbio.F90 
     23 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
     31 
     32CONTAINS 
     33 
     34   SUBROUTINE p4z_meso 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_meso  *** 
     37      !! 
     38      !! ** Purpose :   Compute the sources/sinks for mesozooplankton 
     39      !! 
     40      !! ** Method  : - ??? 
     41      !!--------------------------------------------------------------------- 
     42      INTEGER  ::   ji, jj, jk 
     43      REAL(wp) ::   zcompadi, zcompaph, zcompapoc, zcompaz 
     44      REAL(wp) ::   zfact, zstep, zcompam, zdenom, zgraze2 
     45      !!--------------------------------------------------------------------- 
     46 
     47      zstep = rfact2 / rjjss      ! Time step duration for biology 
     48 
     49      DO jk = 1, jpkm1 
     50         DO jj = 1, jpj 
     51            DO ji = 1, jpi 
     52 
     53               zcompam = MAX( ( trn(ji,jj,jk,jpmes) - 1.e-9 ), 0.e0 ) 
     54# if defined key_off_degrad 
     55               zfact   = zstep * tgfunc(ji,jj,jk) * zcompam * facvol(ji,jj,jk) 
     56# else 
     57               zfact   = zstep * tgfunc(ji,jj,jk) * zcompam 
     58# endif 
     59 
     60!     Respiration rates of both zooplankton 
     61!     ------------------------------------- 
     62               respz2(ji,jj,jk) = resrat2 * zfact * ( 1. + 3. * nitrfac(ji,jj,jk) )        & 
     63                  &             * trn(ji,jj,jk,jpmes) / ( xkmort + trn(ji,jj,jk,jpmes) ) 
     64 
     65!     Zooplankton mortality. A square function has been selected with 
     66!     no real reason except that it seems to be more stable and may 
     67!     mimic predation. 
     68!     --------------------------------------------------------------- 
     69               tortz2(ji,jj,jk) = mzrat2 * 1.e6 * zfact * trn(ji,jj,jk,jpmes) 
     70               ! 
     71            END DO 
     72         END DO 
     73      END DO 
     74 
     75      DO jk = 1, jpkm1 
     76         DO jj = 1, jpj 
     77            DO ji = 1, jpi 
     78 
     79               zcompadi  = MAX( ( trn(ji,jj,jk,jpdia) - 1.e-8 ), 0.e0 ) 
     80               zcompaz   = MAX( ( trn(ji,jj,jk,jpzoo) - 1.e-8 ), 0.e0 ) 
     81               zcompaph  = MAX( ( trn(ji,jj,jk,jpphy) - 2.e-7 ), 0.e0 ) 
     82               zcompapoc = MAX( ( trn(ji,jj,jk,jppoc) - 1.e-8 ), 0.e0 ) 
     83 
     84!     Microzooplankton grazing 
     85!     ------------------------ 
     86               zdenom = 1. / (  xkgraz2 + xprefc   * trn(ji,jj,jk,jpdia)   & 
     87                  &                     + xprefz   * trn(ji,jj,jk,jpzoo)   & 
     88                  &                     + xprefp   * trn(ji,jj,jk,jpphy)   & 
     89                  &                     + xprefpoc * trn(ji,jj,jk,jppoc)  ) 
     90 
     91               zgraze2 = grazrat2 * zstep * Tgfunc2(ji,jj,jk) * zdenom    & 
     92# if defined key_off_degrad 
     93                  &     * facvol(ji,jj,jk)          & 
     94# endif 
     95                  &     * trn(ji,jj,jk,jpmes) 
     96 
     97               grazd  (ji,jj,jk) = zgraze2 * xprefc   * zcompadi 
     98               grazz  (ji,jj,jk) = zgraze2 * xprefz   * zcompaz 
     99               grazn  (ji,jj,jk) = zgraze2 * xprefp   * zcompaph 
     100               grazpoc(ji,jj,jk) = zgraze2 * xprefpoc * zcompapoc 
     101 
     102               graznf (ji,jj,jk) = grazn  (ji,jj,jk) * trn(ji,jj,jk,jpnfe) / (trn(ji,jj,jk,jpphy) + rtrn) 
     103 
     104               graznch(ji,jj,jk) = grazn  (ji,jj,jk) * trn(ji,jj,jk,jpnch) / (trn(ji,jj,jk,jpphy) + rtrn) 
     105 
     106               grazs  (ji,jj,jk) = grazd  (ji,jj,jk) * trn(ji,jj,jk,jpbsi) / (trn(ji,jj,jk,jpdia) + rtrn) 
     107 
     108               grazf  (ji,jj,jk) = grazd  (ji,jj,jk) * trn(ji,jj,jk,jpdfe) / (trn(ji,jj,jk,jpdia) + rtrn) 
     109 
     110               grazdch(ji,jj,jk) = grazd  (ji,jj,jk) * trn(ji,jj,jk,jpdch) / (trn(ji,jj,jk,jpdia) + rtrn) 
     111 
     112               grazpof(ji,jj,jk) = grazpoc(ji,jj,jk) * trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn) 
     113            END DO 
     114         END DO 
     115      END DO 
     116 
     117      DO jk = 1, jpkm1 
     118         DO jj = 1, jpj 
     119            DO ji = 1, jpi 
     120 
     121!    Mesozooplankton flux feeding on GOC 
     122!    ---------------------------------- 
     123# if ! defined key_kriest 
     124               grazffe(ji,jj,jk) = 5.e3 * zstep * wsbio4(ji,jj,jk)          & 
     125#  if defined key_off_degrad 
     126                  &     * facvol(ji,jj,jk)          & 
     127#  endif 
     128                  &     * tgfunc2(ji,jj,jk) * trn(ji,jj,jk,jpgoc) * trn(ji,jj,jk,jpmes) 
     129 
     130               grazfff(ji,jj,jk) = grazffe(ji,jj,jk)         & 
     131                  &     * trn(ji,jj,jk,jpbfe) / (trn(ji,jj,jk,jpgoc) + rtrn) 
     132# else 
     133! KRIEST3 
     134               grazffe(ji,jj,jk) = 0.5 * 1.3e-2 / 5.5e-7 * 0.3 * zstep * wsbio3(ji,jj,jk)     & 
     135                  &     * tgfunc(ji,jj,jk) * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpmes)    & 
     136#  if defined key_off_degrad 
     137                  &     * facvol(ji,jj,jk)          & 
     138#  endif 
     139                  &     /  (trn(ji,jj,jk,jppoc) * 1.e7 + 0.1) 
     140 
     141!!C        grazffe(ji,jj,jk) = 5.e3 * zstep * wsbio3(ji,jj,jk) 
     142!!C     &     * tgfunc2(ji,jj,jk) * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpmes) 
     143!!C#    if defined key_off_degrad 
     144!!C     &     * facvol(ji,jj,jk) 
     145!!C#    endif 
     146 
     147               grazfff(ji,jj,jk) = grazffe(ji,jj,jk)       & 
     148                  &     * trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn) 
     149# endif 
     150            END DO 
     151         END DO 
     152      END DO 
     153 
     154      DO jk = 1, jpkm1 
     155         DO jj = 1, jpj 
     156            DO ji = 1, jpi 
     157 
     158!    Mesozooplankton efficiency 
     159!    -------------------------- 
     160               grarem2(ji,jj,jk) = (grazd(ji,jj,jk) + grazz(ji,jj,jk)              & 
     161                  &     + grazn(ji,jj,jk) + grazpoc(ji,jj,jk) + grazffe(ji,jj,jk))   & 
     162                  &     * (1.-epsher2-unass2) 
    148163#if ! defined key_kriest 
    149         grazffe(ji,jj,jk) = 5E3*zstep*wsbio4(ji,jj,jk) 
    150      &    *tgfunc2(ji,jj,jk)*trn(ji,jj,jk,jpgoc)*trn(ji,jj,jk,jpmes) 
    151 #    if defined key_off_degrad 
    152      &    *facvol(ji,jj,jk) 
    153 #    endif 
    154  
    155         grazfff(ji,jj,jk) = grazffe(ji,jj,jk) 
    156      &    *trn(ji,jj,jk,jpbfe)/(trn(ji,jj,jk,jpgoc)+rtrn) 
     164               grafer2(ji,jj,jk) = (grazf(ji,jj,jk) + graznf(ji,jj,jk)                       & 
     165                  &     + grazz(ji,jj,jk) * ferat3 + grazpof(ji,jj,jk)                       & 
     166                  &     + grazfff(ji,jj,jk)) * (1.-epsher2-unass2)                       & 
     167                  &     + epsher2 * (grazd(ji,jj,jk) * MAX(                       & 
     168                  &    (trn(ji,jj,jk,jpdfe) / (trn(ji,jj,jk,jpdia) + rtrn)                       & 
     169                  &    -ferat3),0.) + grazn(ji,jj,jk) * MAX(                       & 
     170                  &    (trn(ji,jj,jk,jpnfe) / (trn(ji,jj,jk,jpphy) + rtrn)                       & 
     171                  &    -ferat3),0.) + grazpoc(ji,jj,jk) * MAX(                       & 
     172                  &    (trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn)                       & 
     173                  &    -ferat3),0.) + grazffe(ji,jj,jk) * MAX(                       & 
     174                  &    (trn(ji,jj,jk,jpbfe) / (trn(ji,jj,jk,jpgoc) + rtrn)                       & 
     175                  &    -ferat3),0.) ) 
    157176#else 
    158 C KRIEST3 
    159         grazffe(ji,jj,jk) = 0.5*1.3E-2/5.5E-7*0.3*zstep*wsbio3(ji,jj,jk) 
    160      &    *tgfunc(ji,jj,jk)*trn(ji,jj,jk,jppoc)*trn(ji,jj,jk,jpmes) 
    161      &    /(trn(ji,jj,jk,jppoc)*1E7+0.1) 
    162 #    if defined key_off_degrad 
    163      &    *facvol(ji,jj,jk) 
    164 #    endif 
    165  
    166  
    167 C        grazffe(ji,jj,jk) = 5E3*zstep*wsbio3(ji,jj,jk) 
    168 C     &    *tgfunc2(ji,jj,jk)*trn(ji,jj,jk,jppoc)*trn(ji,jj,jk,jpmes) 
    169 C#    if defined key_off_degrad 
    170 C     &    *facvol(ji,jj,jk) 
    171 C#    endif 
    172         grazfff(ji,jj,jk) = grazffe(ji,jj,jk) 
    173      &    *trn(ji,jj,jk,jpsfe)/(trn(ji,jj,jk,jppoc)+rtrn) 
     177               grafer2(ji,jj,jk) = (grazf(ji,jj,jk) + graznf(ji,jj,jk)                       & 
     178                  &     + grazz(ji,jj,jk) * ferat3 + grazpof(ji,jj,jk)                       & 
     179                  &     + grazfff(ji,jj,jk)) * (1.-epsher2-unass2)                       & 
     180                  &     + epsher2 * (grazd(ji,jj,jk) * MAX(                       & 
     181                  &    (trn(ji,jj,jk,jpdfe) / (trn(ji,jj,jk,jpdia) + rtrn)                       & 
     182                  &    -ferat3),0.) + grazn(ji,jj,jk) * MAX(                       & 
     183                  &    (trn(ji,jj,jk,jpnfe) / (trn(ji,jj,jk,jpphy) + rtrn)                       & 
     184                  &    -ferat3),0.) + grazpoc(ji,jj,jk) * MAX(                       & 
     185                  &    (trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn)                       & 
     186                  &    -ferat3),0.) + grazffe(ji,jj,jk) * MAX(                       & 
     187                  &    (trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn)                       & 
     188                  &    -ferat3),0.) ) 
    174189#endif 
    175  
    176  
    177 C 
    178             END DO 
    179           END DO 
    180         END DO 
    181  
    182         DO jk = 1,jpkm1 
    183           DO jj = 1,jpj 
    184             DO ji = 1,jpi 
    185 C 
    186 C    Mesozooplankton efficiency 
    187 C    -------------------------- 
    188 C 
    189         grarem2(ji,jj,jk)=(grazd(ji,jj,jk)+grazz(ji,jj,jk) 
    190      &    +grazn(ji,jj,jk)+grazpoc(ji,jj,jk)+grazffe(ji,jj,jk)) 
    191      &    *(1.-epsher2-unass2) 
    192 #if ! defined key_kriest 
    193         grafer2(ji,jj,jk)=(grazf(ji,jj,jk)+graznf(ji,jj,jk) 
    194      &    +grazz(ji,jj,jk)*ferat3+grazpof(ji,jj,jk) 
    195      &    +grazfff(ji,jj,jk))*(1.-epsher2-unass2) 
    196      &    +epsher2*(grazd(ji,jj,jk)*max( 
    197      &    (trn(ji,jj,jk,jpdfe)/(trn(ji,jj,jk,jpdia)+rtrn) 
    198      &    -ferat3),0.)+grazn(ji,jj,jk)*max( 
    199      &    (trn(ji,jj,jk,jpnfe)/(trn(ji,jj,jk,jpphy)+rtrn) 
    200      &    -ferat3),0.)+grazpoc(ji,jj,jk)*max( 
    201      &    (trn(ji,jj,jk,jpsfe)/(trn(ji,jj,jk,jppoc)+rtrn) 
    202      &    -ferat3),0.)+grazffe(ji,jj,jk)*max( 
    203      &    (trn(ji,jj,jk,jpbfe)/(trn(ji,jj,jk,jpgoc)+rtrn) 
    204      &    -ferat3),0.)) 
     190               grapoc2(ji,jj,jk) = (grazd(ji,jj,jk) + grazz(ji,jj,jk)                     & 
     191                  &     + grazn(ji,jj,jk) + grazpoc(ji,jj,jk) + grazffe(ji,jj,jk)) * unass2 
     192               ! 
     193            END DO 
     194         END DO 
     195      END DO 
     196      ! 
     197   END SUBROUTINE p4z_meso 
     198 
    205199#else 
    206         grafer2(ji,jj,jk)=(grazf(ji,jj,jk)+graznf(ji,jj,jk) 
    207      &    +grazz(ji,jj,jk)*ferat3+grazpof(ji,jj,jk) 
    208      &    +grazfff(ji,jj,jk))*(1.-epsher2-unass2) 
    209      &    +epsher2*(grazd(ji,jj,jk)*max( 
    210      &    (trn(ji,jj,jk,jpdfe)/(trn(ji,jj,jk,jpdia)+rtrn) 
    211      &    -ferat3),0.)+grazn(ji,jj,jk)*max( 
    212      &    (trn(ji,jj,jk,jpnfe)/(trn(ji,jj,jk,jpphy)+rtrn) 
    213      &    -ferat3),0.)+grazpoc(ji,jj,jk)*max( 
    214      &    (trn(ji,jj,jk,jpsfe)/(trn(ji,jj,jk,jppoc)+rtrn) 
    215      &    -ferat3),0.)+grazffe(ji,jj,jk)*max( 
    216      &    (trn(ji,jj,jk,jpsfe)/(trn(ji,jj,jk,jppoc)+rtrn) 
    217      &    -ferat3),0.)) 
    218 #endif 
    219         grapoc2(ji,jj,jk)=(grazd(ji,jj,jk)+grazz(ji,jj,jk) 
    220      &    +grazn(ji,jj,jk)+grazpoc(ji,jj,jk)+grazffe(ji,jj,jk))*unass2 
    221  
    222             END DO 
    223           END DO 
    224         END DO 
    225 C 
    226 #endif 
    227       RETURN 
    228       END 
     200   !!====================================================================== 
     201   !!  Dummy module :                                   No PISCES bio-model 
     202   !!====================================================================== 
     203CONTAINS 
     204   SUBROUTINE p4z_meso                    ! Empty routine 
     205   END SUBROUTINE p4z_meso 
     206#endif  
     207 
     208   !!====================================================================== 
     209END MODULE  p4zmeso 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zmicro.F90

    r774 r775  
     1MODULE p4zmicro 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zmicro  *** 
     4   !! TOP :   PISCES Compute the sources/sinks for microzooplankton 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_micro       :   Compute the sources/sinks for microzooplankton 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc         !  
     17   USE sms             !  
    118 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zmicro 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC           ROUTINE p4zmicro : PISCES MODEL 
    12 CCC           ******************************* 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the sources/sinks for microzooplankton 
    17 CCC 
    18 CC   INPUT : 
    19 CC   ----- 
    20 CC      argument 
    21 CC              None 
    22 CC      common 
    23 CC              all the common defined in opa 
    24 CC 
    25 CC 
    26 CC   OUTPUT :                   : no 
    27 CC   ------ 
    28 CC 
    29 CC   EXTERNAL : 
    30 CC   -------- 
    31 CC              None 
    32 CC 
    33 CC   MODIFICATIONS: 
    34 CC   -------------- 
    35 CC      original  : O. Aumont (2004) 
    36 CC---------------------------------------------------------------------- 
    37 CC parameters and commons 
    38 CC ====================== 
    39 CDIR$ NOLIST 
    40       USE oce_trc 
    41       USE trp_trc 
    42       USE sms 
    43       IMPLICIT NONE 
    44 CDIR$ LIST 
    45 CC---------------------------------------------------------------------- 
    46 CC local declarations 
    47 CC ================== 
    48       INTEGER ji, jj, jk 
    49       REAL compadi,compadi2,compaz,compaph,compapoc 
    50       REAL graze,zdenom,zdenom2 
    51       REAL zfact,zstep,zinano,zidiat,zipoc 
    52 C 
    53 C    Time step duration for biology 
    54 C    ------------------------------ 
    55 C 
    56         zstep=rfact2/rjjss 
    57 C 
     19   IMPLICIT NONE 
     20   PRIVATE 
    5821 
    59         DO jk = 1,jpkm1 
    60           DO jj = 1,jpj 
    61             DO ji = 1,jpi 
    62 C 
    63         compaz = max((trn(ji,jj,jk,jpzoo)-1.E-9),0.) 
    64         zfact=zstep*tgfunc(ji,jj,jk)*compaz 
    65 #    if defined key_off_degrad 
    66      &    *facvol(ji,jj,jk) 
    67 #    endif 
    68 C 
    69 C     Respiration rates of both zooplankton 
    70 C     ------------------------------------- 
    71 C 
    72         respz(ji,jj,jk) = resrat*zfact 
    73      &    *(1.+3.*nitrfac(ji,jj,jk)) 
    74      &    *trn(ji,jj,jk,jpzoo)/(xkmort+trn(ji,jj,jk,jpzoo)) 
    75 C 
    76 C     Zooplankton mortality. A square function has been selected with 
    77 C     no real reason except that it seems to be more stable and may 
    78 C     mimic predation. 
    79 C     --------------------------------------------------------------- 
    80 C 
    81           tortz(ji,jj,jk) = mzrat*1E6*zfact*trn(ji,jj,jk,jpzoo) 
    82 C 
     22   PUBLIC   p4z_micro    ! called in p4zbio.F90 
     23 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
     31 
     32CONTAINS 
     33 
     34   SUBROUTINE p4z_micro 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_micro  *** 
     37      !! 
     38      !! ** Purpose :   Compute the sources/sinks for microzooplankton 
     39      !! 
     40      !! ** Method  : - ??? 
     41      !!--------------------------------------------------------------------- 
     42      INTEGER  ::   ji, jj, jk 
     43      REAL(wp) ::   zcompadi, zcompadi2, zcompaz , zcompaph, zcompapoc 
     44      REAL(wp) ::   zgraze  , zdenom  , zdenom2 
     45      REAL(wp) ::   zfact   , zstep   , zinano , zidiat, zipoc 
     46      !!--------------------------------------------------------------------- 
     47 
     48        zstep = rfact2 / rjjss      ! Time step duration for biology 
     49 
     50      DO jk = 1, jpkm1 
     51         DO jj = 1, jpj 
     52            DO ji = 1, jpi 
     53 
     54               zcompaz = MAX( ( trn(ji,jj,jk,jpzoo) - 1.e-9 ), 0.e0 ) 
     55# if defined key_off_degrad 
     56               zfact   = zstep * tgfunc(ji,jj,jk) * zcompaz *facvol(ji,jj,jk) 
     57# else 
     58               zfact   = zstep * tgfunc(ji,jj,jk) * zcompaz 
     59# endif 
     60 
     61!     Respiration rates of both zooplankton 
     62!     ------------------------------------- 
     63 
     64               respz(ji,jj,jk) = resrat * zfact  * ( 1.+ 3.* nitrfac(ji,jj,jk) )     & 
     65                  &            * trn(ji,jj,jk,jpzoo) / ( xkmort + trn(ji,jj,jk,jpzoo) ) 
     66 
     67!     Zooplankton mortality. A square function has been selected with 
     68!     no real reason except that it seems to be more stable and may 
     69!     mimic predation. 
     70!     --------------------------------------------------------------- 
     71 
     72               tortz(ji,jj,jk) = mzrat * 1.e6 * zfact * trn(ji,jj,jk,jpzoo) 
     73 
    8374            END DO 
    84           END DO 
    85         END DO 
    86 C 
    87         DO jk = 1,jpkm1 
    88           DO jj = 1,jpj 
    89             DO ji = 1,jpi 
    90 C 
    91         compadi = max((trn(ji,jj,jk,jpdia)-1E-8),0.) 
    92         compadi2=min(compadi,5.E-7) 
    93         compaph = max((trn(ji,jj,jk,jpphy)-2E-7),0.) 
    94         compapoc=max((trn(ji,jj,jk,jppoc)-1E-8),0.) 
    95 C 
    96 C     Microzooplankton grazing 
    97 C     ------------------------ 
    98 C 
    99           zdenom2 = 1./(zprefp*compaph 
    100      &      +zprefc*compapoc+zprefd*compadi2+rtrn) 
     75         END DO 
     76      END DO 
    10177 
    102           graze = grazrat*zstep*tgfunc(ji,jj,jk) 
    103      &      *trn(ji,jj,jk,jpzoo) 
    104 #    if defined key_off_degrad 
    105      &      *facvol(ji,jj,jk) 
    106 #    endif 
     78      DO jk = 1, jpkm1 
     79         DO jj = 1, jpj 
     80            DO ji = 1, jpi 
    10781 
    108           zinano=zprefp*compaph*zdenom2 
    109           zipoc=zprefc*compapoc*zdenom2 
    110           zidiat=zprefd*compadi2*zdenom2 
     82               zcompadi  = MAX( ( trn(ji,jj,jk,jpdia) - 1.e-8 ), 0.e0 ) 
     83               zcompadi2 = MIN( zcompadi, 5.e-7 ) 
     84               zcompaph  = MAX( ( trn(ji,jj,jk,jpphy) - 2.e-7 ), 0.e0 ) 
     85               zcompapoc = MAX( ( trn(ji,jj,jk,jppoc) - 1.e-8 ), 0.e0 ) 
    11186 
    112           zdenom = 1./(xkgraz+zinano*compaph 
    113      &      +zipoc*compapoc+zidiat*compadi2) 
     87!     Microzooplankton grazing 
     88!     ------------------------ 
     89               zdenom2 = 1./ ( zprefp * zcompaph + zprefc * zcompapoc + zprefd * zcompadi2 + rtrn ) 
    11490 
    115           grazp(ji,jj,jk) = graze*zinano*compaph*zdenom 
    116           grazm(ji,jj,jk) = graze*zipoc*compapoc*zdenom 
    117           grazsd(ji,jj,jk) = graze*zidiat*compadi2*zdenom 
     91               zgraze = grazrat * zstep * tgfunc(ji,jj,jk)     & 
     92# if defined key_off_degrad 
     93                  &      * facvol(ji,jj,jk)         & 
     94# endif 
     95                  &      * trn(ji,jj,jk,jpzoo) 
    11896 
    119           grazpf(ji,jj,jk) = grazp(ji,jj,jk)* 
    120      &      trn(ji,jj,jk,jpnfe)/(trn(ji,jj,jk,jpphy)+rtrn) 
     97               zinano = zprefp * zcompaph  * zdenom2 
     98               zipoc  = zprefc * zcompapoc * zdenom2 
     99               zidiat = zprefd * zcompadi2 * zdenom2 
    121100 
    122           grazpch(ji,jj,jk) = grazp(ji,jj,jk)* 
    123      &      trn(ji,jj,jk,jpnch)/(trn(ji,jj,jk,jpphy)+rtrn) 
     101               zdenom = 1./ ( xkgraz + zinano * zcompaph + zipoc * zcompapoc + zidiat * zcompadi2 ) 
    124102 
    125           grazmf(ji,jj,jk) = grazm(ji,jj,jk) 
    126      &      *trn(ji,jj,jk,jpsfe)/(trn(ji,jj,jk,jppoc)+rtrn) 
     103               grazp (ji,jj,jk) = zgraze * zinano * zcompaph * zdenom 
     104               grazm (ji,jj,jk) = zgraze * zipoc  * zcompapoc * zdenom 
     105               grazsd(ji,jj,jk) = zgraze * zidiat * zcompadi2 * zdenom 
    127106 
    128           grazsf(ji,jj,jk) = grazsd(ji,jj,jk) 
    129      &      *trn(ji,jj,jk,jpdfe)/(trn(ji,jj,jk,jpdia)+rtrn) 
     107               grazpf (ji,jj,jk) = grazp (ji,jj,jk) * trn(ji,jj,jk,jpnfe) / (trn(ji,jj,jk,jpphy) + rtrn) 
    130108 
    131           grazss(ji,jj,jk) = grazsd(ji,jj,jk) 
    132      &      *trn(ji,jj,jk,jpbsi)/(trn(ji,jj,jk,jpdia)+rtrn) 
     109               grazpch(ji,jj,jk) = grazp (ji,jj,jk) * trn(ji,jj,jk,jpnch) / (trn(ji,jj,jk,jpphy) + rtrn) 
    133110 
    134           grazsch(ji,jj,jk) = grazsd(ji,jj,jk) 
    135      &      *trn(ji,jj,jk,jpdch)/(trn(ji,jj,jk,jpdia)+rtrn) 
    136 C 
     111               grazmf (ji,jj,jk) = grazm (ji,jj,jk) * trn(ji,jj,jk,jpsfe) / (trn(ji,jj,jk,jppoc) + rtrn) 
     112 
     113               grazsf (ji,jj,jk) = grazsd(ji,jj,jk) * trn(ji,jj,jk,jpdfe) / (trn(ji,jj,jk,jpdia) + rtrn) 
     114 
     115               grazss (ji,jj,jk) = grazsd(ji,jj,jk) * trn(ji,jj,jk,jpbsi) / (trn(ji,jj,jk,jpdia) + rtrn) 
     116 
     117               grazsch(ji,jj,jk) = grazsd(ji,jj,jk) * trn(ji,jj,jk,jpdch) / (trn(ji,jj,jk,jpdia) + rtrn) 
     118 
    137119            END DO 
    138           END DO 
    139         END DO 
    140 C 
    141         DO jk = 1,jpkm1 
    142           DO jj = 1,jpj 
    143             DO ji = 1,jpi 
    144 C 
    145 C    Various remineralization and excretion terms 
    146 C    -------------------------------------------- 
    147 C 
    148           grarem(ji,jj,jk)=(grazp(ji,jj,jk)+grazm(ji,jj,jk) 
    149      &      +grazsd(ji,jj,jk))*(1.-epsher-unass) 
     120         END DO 
     121      END DO 
    150122 
    151           grafer(ji,jj,jk)=(grazpf(ji,jj,jk)+grazsf(ji,jj,jk) 
    152      &      +grazmf(ji,jj,jk))*(1.-epsher-unass) 
    153      &      +(grazm(ji,jj,jk)*max((trn(ji,jj,jk,jpsfe)/ 
    154      &      (trn(ji,jj,jk,jppoc)+rtrn)-ferat3),0.) 
    155      &      +grazp(ji,jj,jk)*max((trn(ji,jj,jk,jpnfe)/ 
    156      &      (trn(ji,jj,jk,jpphy)+rtrn)-ferat3),0.) 
    157      &      +grazsd(ji,jj,jk)*max((trn(ji,jj,jk,jpdfe)/ 
    158      &      (trn(ji,jj,jk,jpdia)+rtrn)-ferat3),0.))*epsher 
     123      DO jk = 1, jpkm1 
     124         DO jj = 1, jpj 
     125            DO ji = 1, jpi 
    159126 
    160           grapoc(ji,jj,jk)=(grazp(ji,jj,jk)+grazm(ji,jj,jk) 
    161      &      +grazsd(ji,jj,jk))*unass 
    162 C 
    163               END DO 
     127!    Various remineralization and excretion terms 
     128!    -------------------------------------------- 
     129 
     130               grarem(ji,jj,jk) = (  grazp(ji,jj,jk) + grazm (ji,jj,jk)        & 
     131                  &                                  + grazsd(ji,jj,jk)  ) * ( 1.- epsher - unass ) 
     132 
     133               grafer(ji,jj,jk) = (  grazpf(ji,jj,jk) + grazsf(ji,jj,jk)      & 
     134                  &                                   + grazmf(ji,jj,jk)  ) * ( 1.- epsher - unass )   & 
     135                  &             + (  grazm (ji,jj,jk) * MAX( (trn(ji,jj,jk,jpsfe) /     & 
     136                  &                                          (trn(ji,jj,jk,jppoc) + rtrn) - ferat3), 0.e0 )   & 
     137                  &                + grazp (ji,jj,jk) * MAX( (trn(ji,jj,jk,jpnfe) /   & 
     138                  &                                          (trn(ji,jj,jk,jpphy) + rtrn) - ferat3), 0.e0 )   & 
     139                  &                + grazsd(ji,jj,jk) * MAX( (trn(ji,jj,jk,jpdfe) /   & 
     140                  &                                         (trn(ji,jj,jk,jpdia) + rtrn) - ferat3), 0.e0 )  ) * epsher  
     141 
     142               grapoc(ji,jj,jk) = (  grazp(ji,jj,jk) + grazm(ji,jj,jk) + grazsd(ji,jj,jk)  ) * unass 
     143 
    164144            END DO 
    165           END DO 
    166 C 
    167 #endif 
    168       RETURN 
    169       END 
     145         END DO 
     146      END DO 
     147      ! 
     148   END SUBROUTINE p4z_micro 
     149 
     150#else 
     151   !!====================================================================== 
     152   !!  Dummy module :                                   No PISCES bio-model 
     153   !!====================================================================== 
     154CONTAINS 
     155   SUBROUTINE p4z_micro                    ! Empty routine 
     156   END SUBROUTINE p4z_micro 
     157#endif  
     158 
     159   !!====================================================================== 
     160END MODULE  p4zmicro 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4znano.F90

    r774 r775  
     1MODULE p4znano 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4znano  *** 
     4   !! TOP :   PISCES Compute the mortality terms for nanophytoplankton 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2002     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_nano       :   Compute the mortality terms for nanophytoplankton 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc         !  
     17   USE sms             !  
    118 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4znano 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC          ROUTINE p4znano : PISCES MODEL 
    12 CCC          ****************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the mortality terms for nanophytoplankton 
    17 CCC 
    18 CC   INPUT : 
    19 CC   ----- 
    20 CC      argument 
    21 CC              None 
    22 CC      common 
    23 CC              all the common defined in opa 
    24 CC 
    25 CC 
    26 CC   OUTPUT :                   : no 
    27 CC   ------ 
    28 CC 
    29 CC   EXTERNAL : 
    30 CC   -------- 
    31 CC          None 
    32 CC 
    33 CC   MODIFICATIONS: 
    34 CC   -------------- 
    35 CC      original  : O. Aumont (2002) 
    36 CC---------------------------------------------------------------------- 
    37 CC parameters and commons 
    38 CC ====================== 
    39 CDIR$ NOLIST 
    40       USE oce_trc 
    41       USE trp_trc 
    42       USE sms 
    43       IMPLICIT NONE 
    44 CDIR$ LIST 
    45 CC---------------------------------------------------------------------- 
    46 CC local declarations 
    47 CC ================== 
    48       INTEGER ji, jj, jk 
    49       REAL zfact,zstep,compaph 
    50 C 
    51 C      Time step duration for biology 
    52 C      ------------------------------ 
    53 C 
    54         zstep=rfact2/rjjss 
    55 C 
    56         DO jk = 1,jpkm1 
    57           DO jj = 1,jpj 
    58             DO ji = 1,jpi 
    59 C 
    60         compaph = max((trn(ji,jj,jk,jpphy)-1E-8),0.) 
    61         zfact=1./(trn(ji,jj,jk,jpphy)+rtrn) 
    62 C 
    63 C     Squared mortality of Phyto similar to a sedimentation term during 
    64 C     blooms (Doney et al. 1996) 
    65 C     ----------------------------------------------------------------- 
    66 C 
    67         respp(ji,jj,jk) = wchl*1e6*zstep*zdiss(ji,jj,jk) 
    68      &    *compaph*trn(ji,jj,jk,jpphy) 
    69 #    if defined key_off_degrad 
    70      &    *facvol(ji,jj,jk) 
    71 #    endif 
     19   IMPLICIT NONE 
     20   PRIVATE 
     21 
     22   PUBLIC   p4z_nano    ! called in p4zbio.F90 
     23 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
     31 
     32CONTAINS 
     33 
     34   SUBROUTINE p4z_nano 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_nano  *** 
     37      !! 
     38      !! ** Purpose :   Compute the mortality terms for nanophytoplankton 
     39      !! 
     40      !! ** Method  : - ??? 
     41      !!--------------------------------------------------------------------- 
     42      INTEGER  ::   ji, jj, jk 
     43      REAL(wp) ::   zfact, zstep, zcompaph 
     44      !!--------------------------------------------------------------------- 
     45 
     46 
     47      zstep = rfact2 / rjjss      ! Time step duration for biology 
     48 
     49 
     50      DO jk = 1, jpkm1 
     51         DO jj = 1, jpj 
     52            DO ji = 1, jpi 
     53 
     54               zcompaph = MAX( ( trn(ji,jj,jk,jpphy) - 1e-8 ), 0.e0 ) 
     55               zfact    = 1./ ( trn(ji,jj,jk,jpphy) + rtrn ) 
     56 
     57!     Squared mortality of Phyto similar to a sedimentation term during 
     58!     blooms (Doney et al. 1996) 
     59!     ----------------------------------------------------------------- 
     60               respp(ji,jj,jk) = wchl * 1.e6 * zstep * zdiss(ji,jj,jk)   & 
     61# if defined key_off_degrad 
     62                  &            * facvol(ji,jj,jk)     & 
     63# endif 
     64                  &            * zcompaph * trn(ji,jj,jk,jpphy) 
    7265                                                                                
    73         respnf(ji,jj,jk) = respp(ji,jj,jk) 
    74      &    *trn(ji,jj,jk,jpnfe)*zfact 
     66               respnf (ji,jj,jk) = respp(ji,jj,jk) * trn(ji,jj,jk,jpnfe) * zfact 
    7567                                                                                
    76         respnch(ji,jj,jk) = respp(ji,jj,jk) 
    77      &    *trn(ji,jj,jk,jpnch)*zfact 
    78 C 
    79 C     Phytoplankton mortality. This mortality loss is slightly 
    80 C     increased when nutrients are limiting phytoplankton growth 
    81 C     as observed for instance in case of iron limitation. 
    82 C     ---------------------------------------------------------- 
    83 C 
    84         tortp(ji,jj,jk) = mprat*zstep*trn(ji,jj,jk,jpphy) 
    85      $    /(xkmort+trn(ji,jj,jk,jpphy))*compaph 
    86 #    if defined key_off_degrad 
    87      &    *facvol(ji,jj,jk) 
    88 #    endif 
     68               respnch(ji,jj,jk) = respp(ji,jj,jk) * trn(ji,jj,jk,jpnch) * zfact 
     69 
     70!     Phytoplankton mortality. This mortality loss is slightly 
     71!     increased when nutrients are limiting phytoplankton growth 
     72!     as observed for instance in case of iron limitation. 
     73!     ---------------------------------------------------------- 
     74               tortp  (ji,jj,jk) = mprat * zstep * trn(ji,jj,jk,jpphy)          & 
     75# if defined key_off_degrad 
     76                  &              * facvol(ji,jj,jk)     & 
     77# endif 
     78                  &              / ( xkmort + trn(ji,jj,jk,jpphy) ) * zcompaph 
    8979                                                                                
    90         tortnf(ji,jj,jk)=tortp(ji,jj,jk) 
    91      &    *trn(ji,jj,jk,jpnfe)*zfact 
     80               tortnf (ji,jj,jk) = tortp(ji,jj,jk) * trn(ji,jj,jk,jpnfe) * zfact 
    9281                                                                                
    93         tortnch(ji,jj,jk)=tortp(ji,jj,jk) 
    94      &    *trn(ji,jj,jk,jpnch)*zfact 
    95 C 
     82               tortnch(ji,jj,jk) = tortp(ji,jj,jk) * trn(ji,jj,jk,jpnch) * zfact 
     83 
    9684            END DO 
    97           END DO 
    98         END DO 
    99 C 
    100 #endif 
    101       RETURN 
    102       END 
     85         END DO 
     86      END DO 
     87      ! 
     88   END SUBROUTINE p4z_nano 
     89 
     90#else 
     91   !!====================================================================== 
     92   !!  Dummy module :                                   No PISCES bio-model 
     93   !!====================================================================== 
     94CONTAINS 
     95   SUBROUTINE p4z_nano                    ! Empty routine 
     96   END SUBROUTINE p4z_nano 
     97#endif  
     98 
     99   !!====================================================================== 
     100END MODULE  p4znano 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zopt.F90

    r774 r775  
    1  
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zopt 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC             ROUTINE p4zopt : PISCES MODEL 
    12 CCC             ***************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the light availability in the water column 
    17 CCC         depending on the depth and the chlorophyll concentration 
    18 CCC 
    19 CC   INPUT : 
    20 CC   ----- 
    21 CC      argument 
    22 CC              None 
    23 CC      common 
    24 CC              all the common defined in opa 
    25 CC 
    26 CC 
    27 CC   OUTPUT :                   : no 
    28 CC   ------ 
    29 CC 
    30 CC   MODIFICATIONS: 
    31 CC   -------------- 
    32 CC      original  : O. Aumont (2004) 
    33 CC---------------------------------------------------------------------- 
    34 CC parameters and commons 
    35 CC ====================== 
    36 CDIR$ NOLIST 
    37       USE oce_trc 
    38       USE trp_trc 
    39       USE sms 
    40       IMPLICIT NONE 
    41 #include "domzgr_substitute.h90" 
    42 CDIR$ LIST 
    43 CC---------------------------------------------------------------------- 
    44 CC local declarations 
    45 CC ================== 
    46       INTEGER ji, jj, jk, mrgb 
    47       REAL xchl,ekg(jpi,jpj,jpk),ekr(jpi,jpj,jpk),ekb(jpi,jpj,jpk) 
    48       REAL parlux,e1(jpi,jpj,jpk),e2(jpi,jpj,jpk),e3(jpi,jpj,jpk) 
    49       REAL zdepmoy(jpi,jpj),etmp(jpi,jpj) 
    50       REAL zrlight,zblight,zglight 
    51       REAL zrlight1,zblight1,zglight1 
    52       REAL e3lum(jpi,jpj,jpk),e4lum(jpi,jpj,jpk) 
    53       REAL e5lum(jpi,jpj,jpk),e6lum(jpi,jpj,jpk) 
    54 C 
    55 C     Initialisation of variables used to compute PAR 
    56 C     ----------------------------------------------- 
    57 C 
    58         e1     = 0. 
    59         e2     = 0. 
    60         e3     = 0. 
    61         etot   = 0. 
    62         parlux = 0.43/3. 
    63  
    64         IF (ln_qsr_sms) THEN 
    65 C 
    66 C    IF activated, computation of the qsr for the dynamics 
    67 C    ----------------------------------------------------- 
    68 C 
    69           e3lum=0. 
    70           e4lum=0. 
    71           e5lum=0. 
    72           e6lum=0. 
    73         ENDIF 
    74  
    75         DO jk=1,jpkm1 
    76           DO jj=1,jpj 
    77             DO ji=1,jpi 
    78 C 
    79 C     Separation in three light bands: red, green, blue 
    80 C     ------------------------------------------------- 
    81 C 
    82         xchl=(trn(ji,jj,jk,jpnch)+trn(ji,jj,jk,jpdch)+rtrn)*1.E6 
    83         xchl=max(0.03,xchl) 
    84         xchl=min(10.,xchl) 
     1MODULE p4zopt 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zopt  *** 
     4   !! TOP :   PISCES Compute the light availability in the water column 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_opt        :   Compute the light availability in the water column 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc 
     17   USE sms 
     18 
     19   IMPLICIT NONE 
     20   PRIVATE 
     21 
     22   PUBLIC   p4z_opt   ! called in p4zprg.F90 
     23 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
     31 
     32CONTAINS 
     33 
     34   SUBROUTINE p4z_opt 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_opt  *** 
     37      !! 
     38      !! ** Purpose :   Compute the light availability in the water column 
     39      !!              depending on the depth and the chlorophyll concentration 
     40      !! 
     41      !! ** Method  : - ??? 
     42      !!--------------------------------------------------------------------- 
     43      INTEGER  ::   ji, jj, jk 
     44      INTEGER  ::   irgb 
     45      REAL(wp) ::   zchl, zparlux 
     46      REAL(wp) ::   zrlight , zblight , zglight 
     47      REAL(wp) ::   zrlight1, zblight1, zglight1 
     48      REAL(wp), DIMENSION(jpi,jpj)     ::   zdepmoy, zetmp 
     49      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zekg, zekr, zekb 
     50      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze1 , ze2 , ze3 
     51      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3lum, ze4lum 
     52      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze5lum, ze6lum 
     53      !!--------------------------------------------------------------------- 
     54 
     55!     Initialisation of variables used to compute PAR 
     56!     ----------------------------------------------- 
     57      ze1 (:,:,:) = 0.e0 
     58      ze2 (:,:,:) = 0.e0 
     59      ze3 (:,:,:) = 0.e0 
     60      etot(:,:,:) = 0.e0 
     61         
     62      zparlux = 0.43 / 3. 
     63 
     64!    IF activated, computation of the qsr for the dynamics 
     65!    ----------------------------------------------------- 
     66      IF( ln_qsr_sms ) THEN 
     67         ze3lum(:,:,:) = 0.e0 
     68         ze4lum(:,:,:) = 0.e0 
     69         ze5lum(:,:,:) = 0.e0 
     70         ze6lum(:,:,:) = 0.e0 
     71      ENDIF 
     72 
     73      DO jk = 1, jpkm1 
     74         DO jj = 1, jpj 
     75            DO ji = 1, jpi 
     76 
     77!     Separation in three light bands: red, green, blue 
     78!     ------------------------------------------------- 
     79               zchl = ( trn(ji,jj,jk,jpnch) + trn(ji,jj,jk,jpdch) + rtrn ) * 1.e6 
     80               zchl = MAX( 0.03, zchl ) 
     81               zchl = MIN( 10. , zchl ) 
    8582                                                                                 
    86         mrgb = int(41+20.*log10(xchl)+rtrn) 
     83               irgb = INT( 41 + 20.* LOG10( zchl ) + rtrn ) 
    8784                                                                                 
    88         ekb(ji,jj,jk)=xkrgb(1,mrgb) 
    89         ekg(ji,jj,jk)=xkrgb(2,mrgb) 
    90         ekr(ji,jj,jk)=xkrgb(3,mrgb) 
    91 C 
    92             END DO 
    93           END DO 
    94         END DO 
    95 C 
    96           DO jj = 1,jpj 
    97             DO ji = 1,jpi 
    98 C 
    99 C     Separation in three light bands: red, green, blue 
    100 C     ------------------------------------------------- 
    101 C 
    102         zblight=0.5*ekb(ji,jj,1)*fse3t(ji,jj,1) 
    103         zglight=0.5*ekg(ji,jj,1)*fse3t(ji,jj,1) 
    104         zrlight=0.5*ekr(ji,jj,1)*fse3t(ji,jj,1) 
    105 C 
    106         e1(ji,jj,1) = parlux*qsr(ji,jj)*exp(-zblight) 
    107         e2(ji,jj,1) = parlux*qsr(ji,jj)*exp(-zglight) 
    108         e3(ji,jj,1) = parlux*qsr(ji,jj)*exp(-zrlight) 
    109 C 
    110             END DO 
    111           END DO 
    112  
    113         DO jk = 2,jpkm1 
    114           DO jj = 1,jpj 
    115             DO ji = 1,jpi 
    116 C 
    117 C     Separation in three light bands: red, green, blue 
    118 C     ------------------------------------------------- 
    119 C 
    120         zblight=0.5*(ekb(ji,jj,jk-1)*fse3t(ji,jj,jk-1) 
    121      &    +ekb(ji,jj,jk)*fse3t(ji,jj,jk)) 
    122         zglight=0.5*(ekg(ji,jj,jk-1)*fse3t(ji,jj,jk-1) 
    123      &    +ekg(ji,jj,jk)*fse3t(ji,jj,jk)) 
    124         zrlight=0.5*(ekr(ji,jj,jk-1)*fse3t(ji,jj,jk-1) 
    125      &    +ekr(ji,jj,jk)*fse3t(ji,jj,jk)) 
    126 C 
    127         e1(ji,jj,jk) = e1(ji,jj,jk-1)*exp(-zblight) 
    128         e2(ji,jj,jk) = e2(ji,jj,jk-1)*exp(-zglight) 
    129         e3(ji,jj,jk) = e3(ji,jj,jk-1)*exp(-zrlight) 
    130 C 
    131             END DO 
    132           END DO 
    133         END DO 
    134 C 
    135         etot(:,:,:) = e1(:,:,:)+e2(:,:,:)+e3(:,:,:) 
    136  
    137         IF (ln_qsr_sms) THEN 
    138 C 
    139 C   In the following, the vertical attenuation of qsr for the  
    140 C   dynamics is computed 
    141 C   --------------------------------------------------------- 
    142 C 
    143           DO jj = 1,jpj 
    144             DO ji = 1,jpi 
    145 C 
    146 C     Separation in three light bands: red, green, blue 
    147 C     ------------------------------------------------- 
    148 C 
    149         zblight=0.5*ekb(ji,jj,1)*fse3t(ji,jj,1) 
    150         zglight=0.5*ekg(ji,jj,1)*fse3t(ji,jj,1) 
    151         zrlight=0.5*ekr(ji,jj,1)*fse3t(ji,jj,1) 
    152 C 
    153         e3lum(ji,jj,1) = parlux*qsr(ji,jj) 
    154         e4lum(ji,jj,1) = parlux*qsr(ji,jj) 
    155         e5lum(ji,jj,1) = parlux*qsr(ji,jj) 
    156         e6lum(ji,jj,1) = (1.-3.*parlux)*qsr(ji,jj) 
    157 C 
    158             END DO 
    159           END DO 
    160  
    161         DO jk = 2,jpkm1 
    162           DO jj = 1,jpj 
    163             DO ji = 1,jpi 
    164 C 
    165 C     Separation in three light bands: red, green, blue 
    166 C     ------------------------------------------------- 
    167 C 
    168         zblight1=ekb(ji,jj,jk-1)*fse3t(ji,jj,jk-1) 
    169         zglight1=ekg(ji,jj,jk-1)*fse3t(ji,jj,jk-1) 
    170         zrlight1=ekr(ji,jj,jk-1)*fse3t(ji,jj,jk-1) 
    171  
    172         e3lum(ji,jj,jk) = e3lum(ji,jj,jk-1)*exp(-zblight) 
    173         e4lum(ji,jj,jk) = e4lum(ji,jj,jk-1)*exp(-zglight) 
    174         e5lum(ji,jj,jk) = e5lum(ji,jj,jk-1)*exp(-zrlight) 
    175         e6lum(ji,jj,jk) = e6lum(ji,jj,jk-1) 
    176      &    *exp(-fse3t(ji,jj,jk-1)/xsi1) 
    177 C 
    178             END DO 
    179           END DO 
    180         END DO 
    181  
    182         etot3(:,:,:)=e3lum(:,:,:)+e4lum(:,:,:)+e5lum(:,:,:) 
    183      &    +e6lum(:,:,:) 
    184  
    185         ENDIF 
    186 C     
    187 C     Computation of the euphotic depth 
    188 C     --------------------------------- 
    189 C     
    190         zmeu(:,:) = 300. 
    191  
    192         DO jk = 2,jpkm1 
    193           DO jj = 1,jpj 
    194             DO ji = 1,jpi 
    195         IF (etot(ji,jj,jk).GE.0.0043*qsr(ji,jj)) THEN 
    196            zmeu(ji,jj) = fsdepw(ji,jj,jk+1) 
    197         ENDIF 
    198             END DO 
    199           END DO 
    200         END DO 
    201 C 
    202         zmeu(:,:)=min(300.,zmeu(:,:)) 
    203 C 
    204 C    Computation of the mean light over the mixed layer depth 
    205 C    -------------------------------------------------------- 
    206 C 
    207         zdepmoy  = 0 
    208         etmp  = 0. 
    209         emoy  = 0. 
    210  
    211         DO jk = 1,jpkm1 
    212           DO jj = 1,jpj 
    213             DO ji = 1,jpi 
    214          if (fsdepw(ji,jj,jk+1).le.hmld(ji,jj)) then 
    215        etmp(ji,jj) = etmp(ji,jj)+etot(ji,jj,jk)*fse3t(ji,jj,jk) 
    216        zdepmoy(ji,jj)=zdepmoy(ji,jj)+fse3t(ji,jj,jk) 
    217          endif 
    218             END DO 
    219           END DO 
    220         END DO 
    221  
    222         emoy(:,:,:) = etot(:,:,:) 
    223  
    224         DO jk = 1,jpkm1 
    225           DO jj = 1,jpj 
    226             DO ji = 1,jpi 
    227         IF (fsdepw(ji,jj,jk+1).LE.hmld(ji,jj)) THEN 
    228           emoy(ji,jj,jk) = etmp(ji,jj)/(zdepmoy(ji,jj)+rtrn) 
    229         ENDIF 
    230             END DO 
    231           END DO 
    232         END DO 
    233  
    234 #   if defined key_trc_diaadd 
    235         trc2d(:,:,11) = zmeu(:,:) 
    236 #    endif 
    237 C 
    238 #endif 
    239       RETURN 
    240       END 
     85               zekb(ji,jj,jk) = xkrgb(1,irgb) 
     86               zekg(ji,jj,jk) = xkrgb(2,irgb) 
     87               zekr(ji,jj,jk) = xkrgb(3,irgb) 
     88 
     89            END DO 
     90         END DO 
     91      END DO 
     92 
     93      DO jj = 1,jpj 
     94         DO ji = 1,jpi 
     95 
     96!     Separation in three light bands: red, green, blue 
     97!     ------------------------------------------------- 
     98 
     99            zblight = 0.5 * zekb(ji,jj,1) * fse3t(ji,jj,1) 
     100            zglight = 0.5 * zekg(ji,jj,1) * fse3t(ji,jj,1) 
     101            zrlight = 0.5 * zekr(ji,jj,1) * fse3t(ji,jj,1) 
     102 
     103            ze1(ji,jj,1) = zparlux * qsr(ji,jj) * EXP(-zblight) 
     104            ze2(ji,jj,1) = zparlux * qsr(ji,jj) * EXP(-zglight) 
     105            ze3(ji,jj,1) = zparlux * qsr(ji,jj) * EXP(-zrlight) 
     106 
     107         END DO 
     108      END DO 
     109 
     110      DO jk = 2, jpkm1 
     111          DO jj = 1, jpj 
     112            DO ji = 1, jpi 
     113 
     114!     Separation in three light bands: red, green, blue 
     115!     ------------------------------------------------- 
     116 
     117               zblight = 0.5 * ( zekb(ji,jj,jk-1) * fse3t(ji,jj,jk-1)   & 
     118                  &            + zekb(ji,jj,jk  ) * fse3t(ji,jj,jk  ) ) 
     119               zglight = 0.5 * ( zekg(ji,jj,jk-1) * fse3t(ji,jj,jk-1)   & 
     120                  &            + zekg(ji,jj,jk  ) * fse3t(ji,jj,jk  ) ) 
     121               zrlight = 0.5 * ( zekr(ji,jj,jk-1) * fse3t(ji,jj,jk-1)   & 
     122                  &            + zekr(ji,jj,jk  ) * fse3t(ji,jj,jk  ) ) 
     123 
     124               ze1(ji,jj,jk) = ze1(ji,jj,jk-1) * EXP(-zblight) 
     125               ze2(ji,jj,jk) = ze2(ji,jj,jk-1) * EXP(-zglight) 
     126               ze3(ji,jj,jk) = ze3(ji,jj,jk-1) * EXP(-zrlight) 
     127 
     128            END DO 
     129         END DO 
     130      END DO 
     131 
     132      etot(:,:,:) = ze1(:,:,:) + ze2(:,:,:) + ze3(:,:,:) 
     133 
     134      IF( ln_qsr_sms ) THEN 
     135 
     136!   In the following, the vertical attenuation of qsr for the dynamics is computed 
     137!   ------------------------------------------------------------------------------ 
     138 
     139         DO jj = 1, jpj 
     140            DO ji = 1, jpi 
     141 
     142!     Separation in three light bands: red, green, blue 
     143!     ------------------------------------------------- 
     144 
     145               zblight = 0.5 * zekb(ji,jj,1) * fse3t(ji,jj,1) 
     146               zglight = 0.5 * zekg(ji,jj,1) * fse3t(ji,jj,1) 
     147               zrlight = 0.5 * zekr(ji,jj,1) * fse3t(ji,jj,1) 
     148 
     149               ze3lum(ji,jj,1) = zparlux * qsr(ji,jj) 
     150               ze4lum(ji,jj,1) = zparlux * qsr(ji,jj) 
     151               ze5lum(ji,jj,1) = zparlux * qsr(ji,jj) 
     152               ze6lum(ji,jj,1) = (1.-3. * zparlux) * qsr(ji,jj) 
     153 
     154            END DO 
     155         END DO 
     156 
     157         DO jk = 2, jpkm1 
     158            DO jj = 1, jpj 
     159               DO ji = 1, jpi 
     160 
     161!     Separation in three light bands: red, green, blue 
     162!     ------------------------------------------------- 
     163 
     164                  zblight1 = zekb(ji,jj,jk-1) * fse3t(ji,jj,jk-1) 
     165                  zglight1 = zekg(ji,jj,jk-1) * fse3t(ji,jj,jk-1) 
     166                  zrlight1 = zekr(ji,jj,jk-1) * fse3t(ji,jj,jk-1) 
     167 
     168                  ze3lum(ji,jj,jk) = ze3lum(ji,jj,jk-1) * EXP( -zblight ) 
     169                  ze4lum(ji,jj,jk) = ze4lum(ji,jj,jk-1) * EXP( -zglight ) 
     170                  ze5lum(ji,jj,jk) = ze5lum(ji,jj,jk-1) * EXP( -zrlight ) 
     171                  ze6lum(ji,jj,jk) = ze6lum(ji,jj,jk-1) * EXP( -fse3t(ji,jj,jk-1) / xsi1 ) 
     172 
     173               END DO 
     174            END DO 
     175         END DO 
     176 
     177         etot3(:,:,:) = ze3lum(:,:,:) + ze4lum(:,:,:) + ze5lum(:,:,:) + ze6lum(:,:,:) 
     178 
     179      ENDIF 
     180 
     181!     Computation of the euphotic depth 
     182!     --------------------------------- 
     183     
     184      zmeu(:,:) = 300.e0 
     185 
     186      DO jk = 2, jpkm1 
     187         DO jj = 1, jpj 
     188            DO ji = 1, jpi 
     189               IF( etot(ji,jj,jk) >= 0.0043 * qsr(ji,jj) )   zmeu(ji,jj) = fsdepw(ji,jj,jk+1) 
     190            END DO 
     191         END DO 
     192      END DO 
     193 
     194      zmeu(:,:) = MIN( 300., zmeu(:,:) ) 
     195 
     196!    Computation of the mean light over the mixed layer depth 
     197!    -------------------------------------------------------- 
     198 
     199      zdepmoy(:,:)   = 0.e0 
     200      zetmp  (:,:)   = 0.e0 
     201      emoy   (:,:,:) = 0.e0 
     202 
     203      DO jk = 1, jpkm1 
     204         DO jj = 1, jpj 
     205            DO ji = 1, jpi 
     206               IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
     207                  zetmp  (ji,jj) = zetmp  (ji,jj) + etot(ji,jj,jk) * fse3t(ji,jj,jk) 
     208                  zdepmoy(ji,jj) = zdepmoy(ji,jj) +                  fse3t(ji,jj,jk) 
     209               ENDIF 
     210            END DO 
     211         END DO 
     212      END DO 
     213 
     214      emoy(:,:,:) = etot(:,:,:) 
     215 
     216      DO jk = 1, jpkm1 
     217         DO jj = 1, jpj 
     218            DO ji = 1, jpi 
     219               IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
     220                  emoy(ji,jj,jk) = zetmp(ji,jj) / ( zdepmoy(ji,jj) + rtrn ) 
     221               ENDIF 
     222            END DO 
     223         END DO 
     224      END DO 
     225 
     226# if defined key_trc_diaadd 
     227      trc2d(:,:,11) = zmeu(:,:) 
     228# endif 
     229      ! 
     230   END SUBROUTINE p4z_opt 
     231 
     232#else 
     233   !!====================================================================== 
     234   !!  Dummy module :                                   No PISCES bio-model 
     235   !!====================================================================== 
     236CONTAINS 
     237   SUBROUTINE p4z_opt                   ! Empty routine 
     238   END SUBROUTINE p4z_opt 
     239#endif  
     240 
     241   !!====================================================================== 
     242END MODULE  p4zopt 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zprg.F90

    r774 r775  
     1MODULE p4zprg 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zprg  *** 
     4   !! TOP :   PISCES Source Minus Sink manager 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004-03 (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_prg        :  Time loop of passive tracers sms 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc 
     17   USE sms 
     18   USE lbclnk 
     19   USE lib_mpp 
     20    
     21   USE p4zint          !  
     22   USE p4zche          !  
     23   USE p4zbio          !  
     24   USE p4zsed          !  
     25   USE p4zlys          !  
     26   USE p4zflx          !  
     27    
     28   IMPLICIT NONE 
     29   PRIVATE 
    130 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7        SUBROUTINE p4zprg(kt) 
    8 CCC--------------------------------------------------------------------- 
    9 CCC 
    10 CCC           ROUTINE p4zprg : PISCES MODEL 
    11 CCC           ***************************** 
    12 CCC 
    13 CCC  PURPOSE : 
    14 CCC  --------- 
    15 CCC     Call Biological sources and sinks subroutines 
    16 CCC 
    17 CC   INPUT : 
    18 CC   ----- 
    19 CC      argument 
    20 CC              ktask           : task identificator 
    21 CC              kt              : time step 
    22 CC      common 
    23 CC              all the common defined in opa 
    24 CC 
    25 CC 
    26 CC   OUTPUT :                   : no 
    27 CC   ------ 
    28 CC 
    29 CC   WORKSPACE : 
    30 CC   --------- 
    31 CC 
    32 CC   EXTERNAL : 
    33 CC   -------- 
    34 CC      p4zche, p4zint, p4zlys, p4zbio, p4zsed, p4zflx 
    35 CC 
    36 CC   MODIFICATIONS: 
    37 CC   -------------- 
    38 CC      original  : O. AUMONT (2004) 
    39 CC---------------------------------------------------------------------- 
    40 CC parameters and commons 
    41 CC ====================== 
    42 CDIR$ NOLIST 
    43       USE trp_trc 
    44       USE sms 
    45 CC 
    46       USE oce_trc 
    47       USE lbclnk 
    48       USE lib_mpp 
    49 CC 
    50       IMPLICIT NONE 
    51 CDIR$ LIST 
    52 CC---------------------------------------------------------------------- 
    53 CC local declarations 
    54 CC ================== 
     31   PUBLIC   p4z_prg    ! called in trcsms.F90 
    5532 
    56       INTEGER kt 
    57 #if defined key_top && defined key_pisces 
    58       INTEGER jnt, jn 
     33   !!---------------------------------------------------------------------- 
     34   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     35   !! $Header:$  
     36   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     37   !!---------------------------------------------------------------------- 
    5938 
    60 C 
    61 C this part is without macrotasking coding 
    62 C 
    63 C Call an intermediate routine that in turns, calls chemistry 
    64 C and another routine on a daily basis 
    65 C ----------------------------------------------------------- 
    66 C 
    67       CALL p4zslow(kt) 
     39CONTAINS 
    6840 
    69 C...................................................................... 
    70 C 
    71 C Compute soft tissue production (POC) 
    72 C ------------------------------------ 
    73  
    74        do jnt=1,nrdttrc 
    75 C 
    76          CALL p4zbio 
    77  
    78 C 
    79 C...................................................................... 
    80 C 
    81 C Compute soft tissue remineralisation 
    82 C ------------------------------------ 
    83 C 
    84          CALL p4zsed 
    85  
    86 C 
    87           trb=trn 
    88         END DO 
    89 C 
    90 C...................................................................... 
    91 C 
    92 C Compute CaCO3 saturation 
    93 C ------------------------ 
    94 C 
    95       CALL p4zlys 
    96  
    97 C 
    98 C...................................................................... 
    99 C 
    100 C Compute surface fluxes 
    101 C ---------------------- 
    102 C 
    103       CALL p4zflx 
     41   SUBROUTINE p4z_prg( kt ) 
     42      !!--------------------------------------------------------------------- 
     43      !!                     ***  ROUTINE p4z_prg  *** 
     44      !! 
     45      !! ** Purpose :   Managment of the call to Biological sources and sinks  
     46      !!              routines of PISCES bio-model 
     47      !! 
     48      !! ** Method  : - at each new day ... 
     49      !!              - several calls of bio and sed ??? 
     50      !!              - ... 
     51      !!--------------------------------------------------------------------- 
     52      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
     53      !! 
     54      INTEGER ::   jnt, jn 
     55      INTEGER ::   iyy, imm, idd 
     56      !!--------------------------------------------------------------------- 
    10457 
    10558 
    106       DO jn=1 , jptra 
    107         CALL lbc_lnk(trn(:,:,:,jn), 'T', 1. ) 
    108         CALL lbc_lnk(trb(:,:,:,jn), 'T', 1. ) 
    109         CALL lbc_lnk(tra(:,:,:,jn), 'T', 1. ) 
     59      iyy = ndastp/10000 
     60      imm = (ndastp - iyy*10000)/100 
     61      idd = (ndastp - iyy*10000 - imm*100) 
     62 
     63      IF( ndayflxtr /= idd) THEN      ! New days 
     64         ! 
     65         ndayflxtr = idd 
     66 
     67         CALL p4z_che          ! computation of chemical constants 
     68 
     69         CALL p4z_int( kt )    ! computation of various rates for biogeochemistry 
     70         ! 
     71      ENDIF 
     72 
     73 
     74      DO jnt = 1, nrdttrc             ! ??? 
     75         ! 
     76         CALL p4z_bio          ! Compute soft tissue production (POC) 
     77 
     78         CALL p4z_sed          ! compute soft tissue remineralisation 
     79         ! 
     80         trb(:,:,:,:) = trn(:,:,:,:) 
     81         ! 
    11082      END DO 
    11183 
    112 C 
    113 C...................................................................... 
    114 C 
    115 #endif 
    116 C 
    117       RETURN 
    118       END 
     84      CALL p4z_lys             ! Compute CaCO3 saturation 
     85 
     86      CALL p4z_flx             ! Compute surface fluxes 
     87 
     88      DO jn = 1, jptra 
     89        CALL lbc_lnk( trn(:,:,:,jn), 'T', 1. ) 
     90        CALL lbc_lnk( trb(:,:,:,jn), 'T', 1. ) 
     91        CALL lbc_lnk( tra(:,:,:,jn), 'T', 1. ) 
     92      END DO 
     93      ! 
     94   END SUBROUTINE p4z_prg 
     95 
     96#else 
     97   !!====================================================================== 
     98   !!  Dummy module :                                   No PISCES bio-model 
     99   !!====================================================================== 
     100CONTAINS 
     101   SUBROUTINE p4z_prg( kt )                   ! Empty routine 
     102      INTEGER, INTENT( in ) ::   kt 
     103      WRITE(*,*) 'p4z_prg: You should not have seen this print! error?', kt 
     104   END SUBROUTINE p4z_prg 
     105#endif  
     106 
     107   !!====================================================================== 
     108END MODULE  p4zprg 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zprod.F90

    r774 r775  
    1  
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zprod 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC           ROUTINE p4zprod : PISCES MODEL 
    12 CCC           ****************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute the phytoplankton production depending on 
    17 CCC         light, temperature and nutrient availability 
    18 CCC 
    19 CC   INPUT : 
    20 CC   ----- 
    21 CC      argument 
    22 CC              None 
    23 CC      common 
    24 CC              all the common defined in opa 
    25 CC 
    26 CC 
    27 CC   OUTPUT :                   : no 
    28 CC   ------ 
    29 CC 
    30 CC   EXTERNAL : 
    31 CC   -------- 
    32 CC             p4zday 
    33 CC 
    34 CC   MODIFICATIONS: 
    35 CC   -------------- 
    36 CC      original  : O. Aumont (2004)  
    37 CC---------------------------------------------------------------------- 
    38 CC parameters and commons 
    39 CC ====================== 
    40 CDIR$ NOLIST 
    41       USE oce_trc 
    42       USE trp_trc 
    43       USE sms 
    44       IMPLICIT NONE 
    45 #include "domzgr_substitute.h90" 
    46 CDIR$ LIST 
    47 CC---------------------------------------------------------------------- 
    48 CC local declarations 
    49 CC ================== 
    50       INTEGER ji, jj, jk 
    51       REAL silfac,pislopen(jpi,jpj,jpk),pislope2n(jpi,jpj,jpk) 
    52       REAL zmixnano(jpi,jpj),zmixdiat(jpi,jpj),zfact 
    53       REAL prdiachl,prbiochl,silim,ztn,zadap,zadap2 
    54       REAL ysopt(jpi,jpj,jpk),pislopead(jpi,jpj,jpk) 
    55       REAL prdia(jpi,jpj,jpk),prbio(jpi,jpj,jpk) 
    56       REAL etot2(jpi,jpj,jpk),pislopead2(jpi,jpj,jpk) 
    57       REAL xlim,silfac2,siborn,zprod 
    58       REAL zmxltst,zmxlday,xlim1 
    59 C 
    60 C     Computation of the optimal production 
    61 C     ------------------------------------- 
    62 C 
    63 C 
    64         prmax(:,:,:)=0.6/rjjss*tgfunc(:,:,:) 
    65 #    if defined key_off_degrad 
    66      &  *facvol(:,:,:) 
    67 #    endif 
    68 C 
    69 C     Computation of the day length 
    70 C     ----------------------------- 
    71 C 
    72         call p4zday  
    73  
    74         DO jk = 1,jpkm1 
    75           DO jj = 1,jpj 
    76             DO ji = 1,jpi 
    77 C 
    78 C      Computation of the P-I slope for nanos and diatoms 
    79 C      -------------------------------------------------- 
    80 C 
    81         ztn=max(0.,tn(ji,jj,jk)-15.) 
    82         zadap=1.+2.*ztn/(2.+ztn) 
    83         zadap2=1. 
    84  
    85         zfact=exp(-0.21*emoy(ji,jj,jk)) 
    86  
    87         pislopead(ji,jj,jk)=pislope*(1.+zadap*zfact) 
    88         pislopead2(ji,jj,jk)=pislope2*(1.+zadap2*zfact) 
    89  
    90         pislopen(ji,jj,jk)=pislopead(ji,jj,jk) 
    91      &    *trn(ji,jj,jk,jpnch)/(rtrn+trn(ji,jj,jk,jpphy)*12.) 
    92      &    /(prmax(ji,jj,jk)*rjjss*xlimphy(ji,jj,jk)+rtrn) 
    93  
    94         pislope2n(ji,jj,jk)=pislopead2(ji,jj,jk) 
    95      &    *trn(ji,jj,jk,jpdch)/(rtrn+trn(ji,jj,jk,jpdia)*12.) 
    96      &    /(prmax(ji,jj,jk)*rjjss*xlimdia(ji,jj,jk)+rtrn) 
    97 C 
    98             END DO 
    99           END DO 
    100         END DO 
    101  
    102         DO  jk = 1,jpkm1 
    103           DO  jj = 1,jpj 
    104             DO  ji = 1,jpi 
    105 C 
    106 C     Computation of production function 
    107 C     ---------------------------------- 
    108 C 
    109         prbio(ji,jj,jk) = prmax(ji,jj,jk) 
    110      &    *(1.-exp(-pislopen(ji,jj,jk)*etot(ji,jj,jk))) 
    111         prdia(ji,jj,jk) = prmax(ji,jj,jk) 
    112      &    *(1.-exp(-pislope2n(ji,jj,jk)*etot(ji,jj,jk))) 
    113  
    114             END DO 
    115           END DO 
    116         END DO 
    117  
    118         DO  jk = 1,jpkm1 
    119           DO  jj = 1,jpj 
    120             DO  ji = 1,jpi 
    121 C 
    122 C    Si/C of diatoms 
    123 C    ------------------------ 
    124 C    Si/C increases with iron stress and silicate availability 
    125 C    Si/C is arbitrariliy increased for very high Si concentrations 
    126 C    to mimic the very high ratios observed in the Southern Ocean 
    127 c    (silpot2) 
    128 C 
    129 C 
    130         xlim1=trn(ji,jj,jk,jpsil)/(trn(ji,jj,jk,jpsil)+xksi1) 
    131         xlim=xdiatno3(ji,jj,jk)+xdiatnh4(ji,jj,jk) 
    132 C 
    133         silim=min(prdia(ji,jj,jk)/(rtrn+prmax(ji,jj,jk)), 
    134      &    trn(ji,jj,jk,jpfer)/(concdfe(ji,jj,jk)+trn(ji,jj,jk,jpfer)), 
    135      &    trn(ji,jj,jk,jppo4)/(concdnh4+trn(ji,jj,jk,jppo4)), 
    136      &    xlim) 
    137         silfac=5.4*exp(-4.23*silim)*max(0.,min(1.,2.2*(xlim1-0.5)))+1. 
    138         siborn=max(0.,(trn(ji,jj,jk,jpsil)-15.E-6)) 
    139         silfac2=1.+3.*siborn/(siborn+xksi2) 
    140         silfac=min(6.4,silfac*silfac2) 
    141 C 
    142         ysopt(ji,jj,jk)=grosip*trn(ji,jj,jk,jpsil)/(trn(ji,jj,jk,jpsil) 
    143      $    +xksi1)*silfac 
    144 C 
    145             END DO 
    146           END DO 
    147         END DO 
    148 C 
    149 C    Computation of the limitation term due to 
    150 C    A mixed layer deeper than the euphotic depth 
    151 C    -------------------------------------------- 
    152 C 
    153         DO jj=1,jpj 
    154           DO ji=1,jpi 
    155          zmxltst=max(0.,hmld(ji,jj)-zmeu(ji,jj)) 
    156          zmxlday=zmxltst**2/rjjss 
    157          zmixnano(ji,jj)=1.-zmxlday/(1.+zmxlday) 
    158          zmixdiat(ji,jj)=1.-zmxlday/(3.+zmxlday) 
    159           END DO 
    160         END DO 
     1MODULE p4zprod 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zprod  *** 
     4   !! TOP :   PISCES  
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_prod       :   
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc         !  
     17   USE sms             !  
     18   USE p4zday          ! 
     19    
     20   IMPLICIT NONE 
     21   PRIVATE 
     22 
     23   PUBLIC   p4z_prod    ! called in p4zbio.F90 
     24 
     25   !!* Substitution 
     26#  include "domzgr_substitute.h90" 
     27   !!---------------------------------------------------------------------- 
     28   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     29   !! $Header:$  
     30   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     31   !!---------------------------------------------------------------------- 
     32 
     33CONTAINS 
     34 
     35   SUBROUTINE p4z_prod 
     36      !!--------------------------------------------------------------------- 
     37      !!                     ***  ROUTINE p4z_prod  *** 
     38      !! 
     39      !! ** Purpose :   Compute the phytoplankton production depending on 
     40      !!              light, temperature and nutrient availability 
     41      !! 
     42      !! ** Method  : - ??? 
     43      !!--------------------------------------------------------------------- 
     44      INTEGER  ::   ji, jj, jk 
     45      REAL(wp) ::   zsilfac, zfact 
     46      REAL(wp) ::   zprdiachl, zprbiochl, zsilim, ztn, zadap, zadap2 
     47      REAL(wp) ::   zlim, zsilfac2, zsiborn, zprod 
     48      REAL(wp) ::   zmxltst, zmxlday, zlim1 
     49      REAL(wp), DIMENSION(jpi,jpj)     ::   zmixnano , zmixdiat 
     50      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpislopen, zpislope2n 
     51      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zsopt    , zpislopead 
     52      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zprdia   , zprbio 
     53      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zetot2   , zpislopead2 
     54      !!--------------------------------------------------------------------- 
     55 
     56!     Computation of the optimal production 
     57!     ------------------------------------- 
     58 
     59# if defined key_off_degrad 
     60      prmax(:,:,:) = 0.6 / rjjss * tgfunc(:,:,:) * facvol(:,:,:) 
     61# else 
     62      prmax(:,:,:) = 0.6 / rjjss * tgfunc(:,:,:) 
     63# endif 
     64 
     65      CALL p4z_day       ! Computation of the day length 
     66 
     67 
     68      DO jk = 1, jpkm1 
     69         DO jj = 1, jpj 
     70            DO ji = 1, jpi 
     71 
     72!      Computation of the P-I slope for nanos and diatoms 
     73!      -------------------------------------------------- 
     74 
     75               ztn    = MAX( 0., tn(ji,jj,jk) - 15. ) 
     76               zadap  = 1.+ 2.* ztn / ( 2.+ ztn ) 
     77               zadap2 = 1.e0 
     78 
     79               zfact  = EXP( -0.21 * emoy(ji,jj,jk) ) 
     80 
     81               zpislopead (ji,jj,jk) = pislope  * ( 1.+ zadap  * zfact ) 
     82               zpislopead2(ji,jj,jk) = pislope2 * ( 1.+ zadap2 * zfact ) 
     83 
     84               zpislopen(ji,jj,jk) = zpislopead(ji,jj,jk) * trn(ji,jj,jk,jpnch)               & 
     85                  &                / ( trn(ji,jj,jk,jpphy) * 12.                   + rtrn )   & 
     86                  &                / ( prmax(ji,jj,jk) * rjjss * xlimphy(ji,jj,jk) + rtrn ) 
     87 
     88               zpislope2n(ji,jj,jk) = zpislopead2(ji,jj,jk) * trn(ji,jj,jk,jpdch)              & 
     89                  &                 / ( trn(ji,jj,jk,jpdia) * 12.                   + rtrn )   & 
     90                  &                 / ( prmax(ji,jj,jk) * rjjss * xlimdia(ji,jj,jk) + rtrn ) 
     91 
     92            END DO 
     93         END DO 
     94      END DO 
     95 
     96      DO jk = 1, jpkm1 
     97         DO jj = 1, jpj 
     98            DO ji = 1, jpi 
     99 
     100!     Computation of production function 
     101!     ---------------------------------- 
     102 
     103               zprbio(ji,jj,jk) = prmax(ji,jj,jk) * (  1.- EXP( -zpislopen (ji,jj,jk) * etot(ji,jj,jk) )  ) 
     104               zprdia(ji,jj,jk) = prmax(ji,jj,jk) * (  1.- EXP( -zpislope2n(ji,jj,jk) * etot(ji,jj,jk) )  ) 
     105 
     106            END DO 
     107         END DO 
     108      END DO 
     109 
     110      DO jk = 1, jpkm1 
     111         DO jj = 1, jpj 
     112            DO ji = 1, jpi 
     113 
     114!    Si/C of diatoms 
     115!    ------------------------ 
     116!    Si/C increases with iron stress and silicate availability 
     117!    Si/C is arbitrariliy increased for very high Si concentrations 
     118!    to mimic the very high ratios observed in the Southern Ocean (silpot2) 
     119 
     120               zlim1  = trn(ji,jj,jk,jpsil) / ( trn(ji,jj,jk,jpsil) + xksi1 ) 
     121               zlim   = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) 
     122 
     123               zsilim = MIN( zprdia(ji,jj,jk)    / ( rtrn + prmax(ji,jj,jk) ),                    & 
     124                  &          trn(ji,jj,jk,jpfer) / ( concdfe(ji,jj,jk) + trn(ji,jj,jk,jpfer) ),   & 
     125                  &          trn(ji,jj,jk,jppo4) / ( concdnh4 + trn(ji,jj,jk,jppo4) ),            & 
     126                  &          zlim ) 
     127               zsilfac = 5.4 * EXP( -4.23 * zsilim ) * MAX( 0.e0, MIN( 1., 2.2 * ( zlim1 - 0.5 ) )  ) + 1.e0 
     128               zsiborn = MAX( 0.e0, ( trn(ji,jj,jk,jpsil) - 15.e-6 ) ) 
     129               zsilfac2 = 1.+ 3.* zsiborn / ( zsiborn + xksi2 ) 
     130               zsilfac = MIN( 6.4,zsilfac * zsilfac2) 
     131 
     132               zsopt(ji,jj,jk) = grosip * trn(ji,jj,jk,jpsil) / ( trn(ji,jj,jk,jpsil) + xksi1 ) * zsilfac 
     133 
     134            END DO 
     135         END DO 
     136      END DO 
     137 
     138!    Computation of the limitation term due to 
     139!    A mixed layer deeper than the euphotic depth 
     140!    -------------------------------------------- 
     141 
     142      DO jj = 1, jpj 
     143         DO ji = 1, jpi 
     144            zmxltst = MAX( 0.e0, hmld(ji,jj) - zmeu(ji,jj) ) 
     145            zmxlday = zmxltst**2 / rjjss 
     146            zmixnano(ji,jj) = 1.- zmxlday / ( 1.+ zmxlday ) 
     147            zmixdiat(ji,jj) = 1.- zmxlday / ( 3.+ zmxlday ) 
     148         END DO 
     149      END DO 
    161150                                                                                 
    162         DO  jk = 1,jpkm1 
    163           DO  jj = 1,jpj 
    164             DO  ji = 1,jpi 
    165          if (fsdepw(ji,jj,jk+1).le.hmld(ji,jj)) then 
    166 C 
    167 C     Mixed-layer effect on production 
    168 C     -------------------------------- 
    169 C 
    170          prbio(ji,jj,jk)=prbio(ji,jj,jk)*zmixnano(ji,jj) 
    171          prdia(ji,jj,jk)=prdia(ji,jj,jk)*zmixdiat(ji,jj) 
    172          endif 
    173             END DO 
    174           END DO 
    175         END DO 
    176 C 
    177         DO jk = 1,jpkm1 
    178           DO jj = 1,jpj 
    179             DO ji = 1,jpi 
    180 C 
    181 C      Computation of the maximum light intensity 
    182 C      ------------------------------------------ 
    183 C 
    184         etot2(ji,jj,jk)=etot(ji,jj,jk)*24./(strn(ji,jj)+rtrn) 
    185         IF (strn(ji,jj).lt.1.) etot2(ji,jj,jk)=etot(ji,jj,jk) 
    186 C 
    187             END DO 
    188           END DO 
    189         END DO 
    190  
    191         DO jk = 1,jpkm1 
    192           DO jj = 1,jpj 
    193             DO ji = 1,jpi 
    194 C 
    195 C     Computation of the various production terms for nanophyto. 
    196 C     ---------------------------------------------------------- 
    197 C 
    198         pislopen(ji,jj,jk)=pislopead(ji,jj,jk) 
    199      &    *trn(ji,jj,jk,jpnch)/(rtrn+trn(ji,jj,jk,jpphy)*12.) 
    200      &    /(prmax(ji,jj,jk)*rjjss*max(0.1,xlimphy(ji,jj,jk))+rtrn) 
    201  
    202         prbiochl = prmax(ji,jj,jk) 
    203      &    *(1.-exp(-pislopen(ji,jj,jk)*etot2(ji,jj,jk))) 
    204  
    205         prorca(ji,jj,jk) = prbio(ji,jj,jk) 
    206      &    *xlimphy(ji,jj,jk)*trn(ji,jj,jk,jpphy)*rfact2 
    207  
    208         pronew(ji,jj,jk)=prorca(ji,jj,jk)*xnanono3(ji,jj,jk) 
    209      &    /(xnanono3(ji,jj,jk)+xnanonh4(ji,jj,jk)+rtrn) 
    210         proreg(ji,jj,jk)=prorca(ji,jj,jk)-pronew(ji,jj,jk) 
    211 C 
    212         zprod=rjjss*prorca(ji,jj,jk)*prbiochl*trn(ji,jj,jk,jpphy) 
    213      &    *max(0.1,xlimphy(ji,jj,jk)) 
    214  
    215         prorca5(ji,jj,jk) = (fecnm)**2*zprod/chlcnm 
    216      &    /(pislopead(ji,jj,jk)*etot2(ji,jj,jk)*trn(ji,jj,jk,jpnfe) 
    217      &    +rtrn) 
    218  
    219         prorca6(ji,jj,jk) = chlcnm*144.*zprod/(pislopead(ji,jj,jk) 
    220      &    *etot2(ji,jj,jk)*trn(ji,jj,jk,jpnch)+rtrn) 
    221  
    222             END DO 
    223           END DO 
    224         END DO 
    225  
    226         DO  jk = 1,jpkm1 
    227           DO  jj = 1,jpj 
    228             DO  ji = 1,jpi 
    229 C 
    230 C       Computation of the various production terms for diatoms 
    231 C       ------------------------------------------------------- 
    232 C 
    233         pislope2n(ji,jj,jk)=pislopead2(ji,jj,jk) 
    234      &    *trn(ji,jj,jk,jpdch)/(rtrn+trn(ji,jj,jk,jpdia)*12.) 
    235      &    /(prmax(ji,jj,jk)*rjjss*max(0.1,xlimdia(ji,jj,jk))+rtrn) 
    236  
    237         prdiachl = prmax(ji,jj,jk) 
    238      &    *(1.-exp(-etot2(ji,jj,jk)*pislope2n(ji,jj,jk))) 
    239 C 
    240         prorca2(ji,jj,jk) = prdia(ji,jj,jk) 
    241      &    *xlimdia(ji,jj,jk)*trn(ji,jj,jk,jpdia)*rfact2 
    242  
    243 C 
    244         pronew2(ji,jj,jk)=prorca2(ji,jj,jk)*xdiatno3(ji,jj,jk) 
    245      &    /(xdiatno3(ji,jj,jk)+xdiatnh4(ji,jj,jk)+rtrn) 
    246         proreg2(ji,jj,jk)=prorca2(ji,jj,jk)-pronew2(ji,jj,jk) 
    247         prorca3(ji,jj,jk) = prorca2(ji,jj,jk)*ysopt(ji,jj,jk) 
    248 C 
    249         zprod=rjjss*prorca2(ji,jj,jk)*prdiachl*trn(ji,jj,jk,jpdia) 
    250      &    *max(0.1,xlimdia(ji,jj,jk)) 
    251  
    252 C 
    253         prorca4(ji,jj,jk) = (fecdm)**2*zprod/chlcdm 
    254      &    /(pislopead2(ji,jj,jk)*etot2(ji,jj,jk)*trn(ji,jj,jk,jpdfe) 
    255      &    +rtrn) 
    256 C 
    257         prorca7(ji,jj,jk) = chlcdm*144.*zprod/(pislopead2(ji,jj,jk) 
    258      &    *etot2(ji,jj,jk)*trn(ji,jj,jk,jpdch)+rtrn) 
    259 C 
    260             END DO 
    261           END DO 
    262         END DO 
    263 C 
    264 #endif 
    265       RETURN 
    266       END 
     151      DO jk = 1, jpkm1 
     152         DO jj = 1, jpj 
     153            DO ji = 1, jpi 
     154               IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
     155 
     156!     Mixed-layer effect on production 
     157!     -------------------------------- 
     158                  zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * zmixnano(ji,jj) 
     159                  zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * zmixdiat(ji,jj) 
     160               ENDIF 
     161            END DO 
     162         END DO 
     163      END DO 
     164 
     165      DO jk = 1, jpkm1 
     166         DO jj = 1, jpj 
     167            DO ji = 1, jpi 
     168 
     169!      Computation of the maximum light intensity 
     170!      ------------------------------------------ 
     171               zetot2(ji,jj,jk) = etot(ji,jj,jk) * 24. / ( strn(ji,jj) + rtrn ) 
     172               IF( strn(ji,jj) < 1.e0 )   zetot2(ji,jj,jk) = etot(ji,jj,jk) 
     173 
     174            END DO 
     175         END DO 
     176      END DO 
     177 
     178      DO jk = 1, jpkm1 
     179         DO jj = 1, jpj 
     180            DO ji = 1, jpi 
     181 
     182!     Computation of the various production terms for nanophyto. 
     183!     ---------------------------------------------------------- 
     184               zpislopen(ji,jj,jk) = zpislopead(ji,jj,jk)          & 
     185                  &                * trn(ji,jj,jk,jpnch) / ( rtrn + trn(ji,jj,jk,jpphy) * 12.)         & 
     186                  &                / ( prmax(ji,jj,jk) * rjjss * MAX( 0.1, xlimphy(ji,jj,jk) ) + rtrn ) 
     187 
     188               zprbiochl = prmax(ji,jj,jk) * (  1.- EXP( -zpislopen(ji,jj,jk) * zetot2(ji,jj,jk) )  ) 
     189 
     190               prorca(ji,jj,jk) = zprbio(ji,jj,jk)  * xlimphy(ji,jj,jk) * trn(ji,jj,jk,jpphy) * rfact2 
     191 
     192               pronew(ji,jj,jk) = prorca(ji,jj,jk) * xnanono3(ji,jj,jk)    & 
     193                  &             / ( xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) + rtrn ) 
     194               proreg(ji,jj,jk) = prorca(ji,jj,jk) - pronew(ji,jj,jk) 
     195 
     196               zprod = rjjss * prorca(ji,jj,jk) * zprbiochl * trn(ji,jj,jk,jpphy)   & 
     197                  &                             * MAX( 0.1, xlimphy(ji,jj,jk) ) 
     198 
     199               prorca5(ji,jj,jk) = (fecnm)**2 * zprod / chlcnm            & 
     200                  &              / (  zpislopead(ji,jj,jk) * zetot2(ji,jj,jk) * trn(ji,jj,jk,jpnfe) + rtrn  ) 
     201 
     202               prorca6(ji,jj,jk) = chlcnm * 144. * zprod                  & 
     203                  &              / (  zpislopead(ji,jj,jk) * zetot2(ji,jj,jk) * trn(ji,jj,jk,jpnch) + rtrn  ) 
     204 
     205            END DO 
     206         END DO 
     207      END DO 
     208 
     209      DO jk = 1, jpkm1 
     210         DO jj = 1, jpj 
     211            DO ji = 1, jpi 
     212 
     213!       Computation of the various production terms for diatoms 
     214!       ------------------------------------------------------- 
     215               zpislope2n(ji,jj,jk) = zpislopead2(ji,jj,jk) * trn(ji,jj,jk,jpdch)        & 
     216                  &                 / ( rtrn + trn(ji,jj,jk,jpdia) * 12.)        & 
     217                  &                 / ( prmax(ji,jj,jk) * rjjss * MAX( 0.1, xlimdia(ji,jj,jk) ) + rtrn ) 
     218 
     219               zprdiachl = prmax(ji,jj,jk) * (  1.- EXP( -zetot2(ji,jj,jk) * zpislope2n(ji,jj,jk) )  ) 
     220 
     221               prorca2(ji,jj,jk) = zprdia(ji,jj,jk) * xlimdia(ji,jj,jk) * trn(ji,jj,jk,jpdia) * rfact2 
     222 
     223               pronew2(ji,jj,jk) = prorca2(ji,jj,jk) * xdiatno3(ji,jj,jk)     & 
     224                  &              / ( xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) + rtrn ) 
     225               proreg2(ji,jj,jk) = prorca2(ji,jj,jk) - pronew2(ji,jj,jk) 
     226               prorca3(ji,jj,jk) = prorca2(ji,jj,jk) * zsopt(ji,jj,jk) 
     227 
     228               zprod=rjjss * prorca2(ji,jj,jk) * zprdiachl * trn(ji,jj,jk,jpdia) * MAX( 0.1, xlimdia(ji,jj,jk) ) 
     229 
     230               prorca4(ji,jj,jk) = (fecdm)**2 * zprod / chlcdm                   & 
     231                  &              / ( zpislopead2(ji,jj,jk) * zetot2(ji,jj,jk) * trn(ji,jj,jk,jpdfe) + rtrn ) 
     232 
     233               prorca7(ji,jj,jk) = chlcdm * 144. * zprod       & 
     234                  &              / ( zpislopead2(ji,jj,jk) * zetot2(ji,jj,jk) * trn(ji,jj,jk,jpdch) + rtrn ) 
     235 
     236            END DO 
     237         END DO 
     238      END DO 
     239      ! 
     240   END SUBROUTINE p4z_prod 
     241 
     242#else 
     243   !!====================================================================== 
     244   !!  Dummy module :                                   No PISCES bio-model 
     245   !!====================================================================== 
     246CONTAINS 
     247   SUBROUTINE p4z_prod                    ! Empty routine 
     248   END SUBROUTINE p4z_prod 
     249#endif  
     250 
     251   !!====================================================================== 
     252END MODULE  p4zprod 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zrem.F90

    r774 r775  
    1  
    2 CCC $Header: /home/opalod/NEMOCVSROOT/NEMO/TOP_SRC/SMS/p4zrem.F,v 1.8 2007/10/12 09:28:41 opalod Exp $  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zrem 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC          ROUTINE p4zrem : PISCES MODEL 
    12 CCC          ***************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute remineralization/scavenging of organic compounds 
    17 CCC 
    18 CC   INPUT : 
    19 CC   ----- 
    20 CC      common 
    21 CC              all the common defined in opa 
    22 CC 
    23 CC 
    24 CC   OUTPUT :                   : no 
    25 CC   ------ 
    26 CC 
    27 CC   EXTERNAL : 
    28 CC   -------- 
    29 CC            None 
    30 CC 
    31 CC   MODIFICATIONS: 
    32 CC   -------------- 
    33 CC      original  : 2004 - O. Aumont  
    34 CC---------------------------------------------------------------------- 
    35 CC parameters and commons 
    36 CC ====================== 
    37 CDIR$ NOLIST 
    38       USE oce_trc 
    39       USE trp_trc 
    40       USE sms 
    41       IMPLICIT NONE 
    42 #include "domzgr_substitute.h90" 
    43 CDIR$ LIST 
    44 CC---------------------------------------------------------------------- 
    45 CC local declarations 
    46 CC ================== 
    47       INTEGER ji, jj, jk 
    48       REAL remip,remik,xlam1b 
    49       REAL xkeq,xfeequi,siremin 
    50       REAL zsatur,zsatur2,znusil,zdepbac(jpi,jpj,jpk) 
    51       REAL zlamfac,zstep,fesatur(jpi,jpj,jpk) 
    52       REAL ztempbac(jpi,jpj) 
    53 C 
    54 C      Time step duration for the biology 
    55 C 
    56        zstep=rfact2/rjjss 
    57 C 
    58 C      Computation of the mean phytoplankton concentration as 
    59 C      a crude estimate of the bacterial biomass 
    60 C      -------------------------------------------------- 
    61 C 
    62         DO jk=1,jpkm1 
    63           DO jj = 1, jpj 
    64             DO ji = 1, jpi 
    65          IF (fsdept(ji,jj,jk).lt.120.) THEN 
    66          zdepbac(ji,jj,jk)=min(0.7*(trn(ji,jj,jk,jpzoo) 
    67      &     +2*trn(ji,jj,jk,jpmes)),4E-6) 
    68          ztempbac(ji,jj)=zdepbac(ji,jj,jk) 
    69          ELSE 
    70          zdepbac(ji,jj,jk)=min(1.,120./fsdept(ji,jj,jk)) 
    71      &      *ztempbac(ji,jj) 
    72          ENDIF 
    73             END DO 
    74           END DO 
    75         END DO 
    76  
    77          DO jk = 1,jpkm1 
    78            DO jj = 1,jpj 
    79              DO ji = 1,jpi 
    80 C 
    81 C    DENITRIFICATION FACTOR COMPUTED FROM O2 LEVELS 
    82 C    ---------------------------------------------- 
    83 C 
    84           nitrfac(ji,jj,jk)= 
    85      &      max(0.,0.4*(6.E-6-trn(ji,jj,jk,jpoxy))/(oxymin+ 
    86      &      trn(ji,jj,jk,jpoxy))) 
    87              END DO 
    88            END DO 
    89          END DO 
    90  
    91           nitrfac(:,:,:)=min(1.,nitrfac(:,:,:)) 
    92  
    93          DO jk = 1,jpkm1 
    94            DO jj = 1,jpj 
    95              DO ji = 1,jpi 
    96 C 
    97 C     DOC ammonification. Depends on depth, phytoplankton biomass 
    98 C     and a limitation term which is supposed to be a parameterization 
    99 C     of the bacterial activity.  
    100 C     ---------------------------------------------------------------- 
    101 C 
    102          remik = xremik*zstep/1E-6*xlimbac(ji,jj,jk) 
    103      &     *zdepbac(ji,jj,jk) 
     1MODULE p4zrem 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zrem  *** 
     4   !! TOP :   PISCES Compute remineralization/scavenging of organic compounds 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_top'       and                                      TOP models 
     12   !!   'key_pisces'                                       PISCES bio-model 
     13   !!---------------------------------------------------------------------- 
     14   !!   p4z_rem       :   Compute remineralization/scavenging of organic compounds 
     15   !!---------------------------------------------------------------------- 
     16   USE oce_trc         ! 
     17   USE trp_trc         !  
     18   USE sms             !  
     19 
     20   IMPLICIT NONE 
     21   PRIVATE 
     22 
     23   PUBLIC   p4z_rem    ! called in p4zbio.F90 
     24 
     25   !!* Substitution 
     26#  include "domzgr_substitute.h90" 
     27   !!---------------------------------------------------------------------- 
     28   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     29   !! $Header:$  
     30   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     31   !!---------------------------------------------------------------------- 
     32 
     33CONTAINS 
     34 
     35   SUBROUTINE p4z_rem 
     36      !!--------------------------------------------------------------------- 
     37      !!                     ***  ROUTINE p4z_rem  *** 
     38      !! 
     39      !! ** Purpose :   Compute remineralization/scavenging of organic compounds 
     40      !! 
     41      !! ** Method  : - ??? 
     42      !!--------------------------------------------------------------------- 
     43      INTEGER  ::   ji, jj, jk 
     44      REAL(wp) ::   zremip, zremik , zlam1b 
     45      REAL(wp) ::   zkeq  , zfeequi, zsiremin 
     46      REAL(wp) ::   zsatur, zsatur2, znusil 
     47      REAL(wp) ::   zlamfac, zstep 
     48      REAL(wp), DIMENSION(jpi,jpj)     ::   ztempbac 
     49      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdepbac, zfesatur 
     50      !!--------------------------------------------------------------------- 
     51 
     52       zstep = rfact2 / rjjss      ! Time step duration for the biology 
     53 
     54 
     55!      Computation of the mean phytoplankton concentration as 
     56!      a crude estimate of the bacterial biomass 
     57!      -------------------------------------------------- 
     58 
     59      DO jk = 1, jpkm1 
     60         DO jj = 1, jpj 
     61            DO ji = 1, jpi 
     62               IF( fsdept(ji,jj,jk) < 120. ) THEN 
     63                  zdepbac(ji,jj,jk) = MIN( 0.7 * ( trn(ji,jj,jk,jpzoo) + 2.* trn(ji,jj,jk,jpmes) ), 4.e-6 ) 
     64                  ztempbac(ji,jj)   = zdepbac(ji,jj,jk) 
     65               ELSE 
     66                  zdepbac(ji,jj,jk) = MIN( 1., 120./ fsdept(ji,jj,jk) ) * ztempbac(ji,jj) 
     67               ENDIF 
     68            END DO 
     69         END DO 
     70      END DO 
     71 
     72      DO jk = 1, jpkm1 
     73         DO jj = 1, jpj 
     74            DO ji = 1, jpi 
     75 
     76!    DENITRIFICATION FACTOR COMPUTED FROM O2 LEVELS 
     77!    ---------------------------------------------- 
     78 
     79               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trn(ji,jj,jk,jpoxy) )    & 
     80                  &                                / ( oxymin + trn(ji,jj,jk,jpoxy) )  ) 
     81            END DO 
     82         END DO 
     83      END DO 
     84 
     85      nitrfac(:,:,:) = MIN( 1., nitrfac(:,:,:) ) 
     86 
     87      DO jk = 1, jpkm1 
     88         DO jj = 1, jpj 
     89            DO ji = 1, jpi 
     90 
     91!     DOC ammonification. Depends on depth, phytoplankton biomass 
     92!     and a limitation term which is supposed to be a parameterization 
     93!     of the bacterial activity.  
     94!     ---------------------------------------------------------------- 
     95               zremik = xremik * zstep / 1.e-6 * xlimbac(ji,jj,jk)         & 
     96# if defined key_off_degrad 
     97                  &            * facvol(ji,jj,jk)              & 
     98# endif 
     99                  &            * zdepbac(ji,jj,jk) 
     100               zremik = MAX( zremik, 5.5e-4 * zstep ) 
     101 
     102!     Ammonification in oxic waters with oxygen consumption 
     103!     ----------------------------------------------------- 
     104               olimi(ji,jj,jk) = MIN(  ( trn(ji,jj,jk,jpoxy) - rtrn ) / o2ut,                     & 
     105                  &                    zremik * ( 1.- nitrfac(ji,jj,jk) ) * trn(ji,jj,jk,jpdoc)  )  
     106 
     107!     Ammonification in suboxic waters with denitrification 
     108!     ------------------------------------------------------- 
     109               denitr(ji,jj,jk) = MIN(  ( trn(ji,jj,jk,jpno3) - rtrn ) / rdenit,           & 
     110                  &                     zremik * nitrfac(ji,jj,jk) * trn(ji,jj,jk,jpdoc)  ) 
     111            END DO 
     112         END DO 
     113      END DO 
     114 
     115      olimi (:,:,:) = MAX( 0.e0, olimi (:,:,:) ) 
     116      denitr(:,:,:) = MAX( 0.e0, denitr(:,:,:) ) 
     117 
     118      DO jk = 1, jpkm1 
     119         DO jj = 1, jpj 
     120            DO ji = 1, jpi 
     121 
     122!    NH4 nitrification to NO3. Ceased for oxygen concentrations 
     123!    below 2 umol/L. Inhibited at strong light  
     124!    ---------------------------------------------------------- 
     125               onitr(ji,jj,jk) = nitrif * zstep * trn(ji,jj,jk,jpnh4) / ( 1.+ emoy(ji,jj,jk) )     & 
     126# if defined key_off_degrad 
     127                  &            * facvol(ji,jj,jk)              & 
     128# endif 
     129                  &            * ( 1.- nitrfac(ji,jj,jk) ) 
     130            END DO 
     131         END DO 
     132      END DO 
     133 
     134      DO jk = 1, jpkm1 
     135         DO jj = 1, jpj 
     136            DO ji = 1, jpi 
     137 
     138!    Bacterial uptake of iron. No iron is available in DOC. So 
     139!    Bacteries are obliged to take up iron from the water. Some 
     140!    studies (especially at Papa) have shown this uptake to be 
     141!    significant 
     142!    ---------------------------------------------------------- 
     143               xbactfer(ji,jj,jk) = 15.e-6 * rfact2 * 4.* 0.4 * prmax(ji,jj,jk)           & 
     144                  &               * ( xlimphy(ji,jj,jk) * zdepbac(ji,jj,jk))**2           & 
     145                  &                  / ( xkgraz2 + zdepbac(ji,jj,jk) )                    & 
     146                  &                  * ( 0.5 + SIGN( 0.5, trn(ji,jj,jk,jpfer) -2.e-11 )  ) 
     147 
     148            END DO 
     149         END DO 
     150      END DO 
     151 
     152      DO jk = 1, jpkm1 
     153         DO jj = 1, jpj 
     154            DO ji = 1, jpi 
     155 
     156!    POC disaggregation by turbulence and bacterial activity.  
     157!    ------------------------------------------------------------- 
     158               zremip = xremip * zstep * tgfunc(ji,jj,jk)   & 
     159# if defined key_off_degrad 
     160                  &            * facvol(ji,jj,jk)              & 
     161# endif 
     162                  &            * ( 1.- 0.5 * nitrfac(ji,jj,jk) ) 
     163 
     164!    POC disaggregation rate is reduced in anoxic zone as shown by 
     165!    sediment traps data. In oxic area, the exponent of the martin s 
     166!    law is around -0.87. In anoxic zone, it is around -0.35. This 
     167!    means a disaggregation constant about 0.5 the value in oxic zones 
     168!    ----------------------------------------------------------------- 
     169               orem (ji,jj,jk) = zremip * trn(ji,jj,jk,jppoc) 
     170               ofer (ji,jj,jk) = zremip * trn(ji,jj,jk,jpsfe) 
     171#if ! defined key_kriest 
     172               orem2(ji,jj,jk) = zremip * trn(ji,jj,jk,jpgoc) 
     173               ofer2(ji,jj,jk) = zremip * trn(ji,jj,jk,jpbfe) 
     174#else 
     175               orem2(ji,jj,jk) = zremip * trn(ji,jj,jk,jpnum) 
     176#endif 
     177            END DO 
     178         END DO 
     179      END DO 
     180 
     181      DO jk = 1, jpkm1 
     182         DO jj = 1, jpj 
     183            DO ji = 1, jpi 
     184 
     185!     Remineralization rate of BSi depedant on T and saturation 
     186!     --------------------------------------------------------- 
     187               zsatur  = ( sio3eq(ji,jj,jk) - trn(ji,jj,jk,jpsil) ) / ( sio3eq(ji,jj,jk) + rtrn ) 
     188               zsatur  = MAX( rtrn, zsatur ) 
     189               zsatur2 = zsatur * ( 1. + tn(ji,jj,jk) / 400.)**4 
     190               znusil  = 0.225  * ( 1. + tn(ji,jj,jk) / 15.) * zsatur + 0.775 * zsatur2**9 
    104191#    if defined key_off_degrad 
    105      &     *facvol(ji,jj,jk) 
     192               zsiremin = xsirem * zstep * znusil * facvol(ji,jj,jk) 
     193# else 
     194               zsiremin = xsirem * zstep * znusil 
    106195#    endif 
    107          remik=max(remik,5.5E-4*zstep) 
    108 C 
    109 C     Ammonification in oxic waters with oxygen consumption 
    110 C     ----------------------------------------------------- 
    111 C 
    112          olimi(ji,jj,jk)=min((trn(ji,jj,jk,jpoxy)-rtrn)/o2ut, 
    113      &     remik*(1.-nitrfac(ji,jj,jk))*trn(ji,jj,jk,jpdoc))  
    114 C 
    115 C     Ammonification in suboxic waters with denitrification 
    116 C     ------------------------------------------------------- 
    117 C 
    118          denitr(ji,jj,jk)=min((trn(ji,jj,jk,jpno3)-rtrn)/rdenit, 
    119      &     remik*nitrfac(ji,jj,jk)*trn(ji,jj,jk,jpdoc)) 
    120              END DO 
    121            END DO 
    122          END DO 
    123 C 
    124          olimi(:,:,:)=max(0.,olimi(:,:,:)) 
    125          denitr(:,:,:)=max(0.,denitr(:,:,:)) 
    126 C 
    127          DO jk = 1,jpkm1 
    128            DO jj = 1,jpj 
    129              DO ji = 1,jpi 
    130 C 
    131 C    NH4 nitrification to NO3. Ceased for oxygen concentrations 
    132 C    below 2 umol/L. Inhibited at strong light  
    133 C    ---------------------------------------------------------- 
    134 C 
    135          onitr(ji,jj,jk)=nitrif*zstep*trn(ji,jj,jk,jpnh4)/(1. 
    136      &     +emoy(ji,jj,jk))*(1.-nitrfac(ji,jj,jk)) 
    137 #    if defined key_off_degrad 
    138      &     *facvol(ji,jj,jk) 
    139 #    endif 
    140              END DO 
    141            END DO 
    142          END DO 
    143  
    144          DO jk = 1,jpkm1 
    145            DO jj = 1,jpj 
    146              DO ji = 1,jpi 
    147 C 
    148 C    Bacterial uptake of iron. No iron is available in DOC. So 
    149 C    Bacteries are obliged to take up iron from the water. Some 
    150 C    studies (especially at Papa) have shown this uptake to be 
    151 C    significant 
    152 C    ---------------------------------------------------------- 
    153 C 
    154          xbactfer(ji,jj,jk)=15E-6*rfact2*4.*0.4*prmax(ji,jj,jk) 
    155      &     *(xlimphy(ji,jj,jk)*zdepbac(ji,jj,jk))**2 
    156      &     /(xkgraz2+zdepbac(ji,jj,jk)) 
    157      &     *(0.5+sign(0.5,trn(ji,jj,jk,jpfer)-2E-11)) 
    158 C 
    159              END DO 
    160            END DO 
    161          END DO 
    162 C 
    163          DO jk = 1,jpkm1 
    164            DO jj = 1,jpj 
    165              DO ji = 1,jpi 
    166 C 
    167 C    POC disaggregation by turbulence and bacterial activity.  
    168 C    ------------------------------------------------------------- 
    169 C 
    170          remip=xremip*zstep*tgfunc(ji,jj,jk)*(1.-0.5*nitrfac(ji,jj,jk)) 
    171 #    if defined key_off_degrad 
    172      &     *facvol(ji,jj,jk) 
    173 #    endif 
    174 C 
    175 C    POC disaggregation rate is reduced in anoxic zone as shown by 
    176 C    sediment traps data. In oxic area, the exponent of the martin's 
    177 C    law is around -0.87. In anoxic zone, it is around -0.35. This 
    178 C    means a disaggregation constant about 0.5 the value in oxic zones 
    179 C    ----------------------------------------------------------------- 
    180 C 
    181          orem(ji,jj,jk)=remip*trn(ji,jj,jk,jppoc) 
    182          ofer(ji,jj,jk)=remip*trn(ji,jj,jk,jpsfe) 
     196               osil(ji,jj,jk) = zsiremin * trn(ji,jj,jk,jpdsi) 
     197               ! 
     198            END DO 
     199         END DO 
     200      END DO 
     201 
     202      zfesatur(:,:,:) = 0.6e-9 
     203 
     204      DO jk = 1, jpkm1 
     205         DO jj = 1, jpj 
     206            DO ji = 1, jpi 
     207 
     208!     scavenging rate of iron. this scavenging rate depends on the 
     209!     load in particles on which they are adsorbed. The 
     210!     parameterization has been taken from studies on Th 
     211!     ------------------------------------------------------------ 
     212               zkeq = fekeq(ji,jj,jk) 
     213               zfeequi = ( -( 1. + zfesatur(ji,jj,jk) * zkeq - zkeq * trn(ji,jj,jk,jpfer) )               & 
     214                  &        + SQRT( ( 1. + zfesatur(ji,jj,jk) * zkeq - zkeq * trn(ji,jj,jk,jpfer) )**2       & 
     215                  &               + 4. * trn(ji,jj,jk,jpfer) * zkeq) ) / ( 2. * zkeq ) 
    183216#if ! defined key_kriest 
    184          orem2(ji,jj,jk)=remip*trn(ji,jj,jk,jpgoc) 
    185          ofer2(ji,jj,jk)=remip*trn(ji,jj,jk,jpbfe) 
    186 #else 
    187          orem2(ji,jj,jk)=remip*trn(ji,jj,jk,jpnum) 
     217               zlam1b = 3.e-5 + xlam1 * (  trn(ji,jj,jk,jppoc) + trn(ji,jj,jk,jpgoc)   & 
     218                  &                      + trn(ji,jj,jk,jpcal) + trn(ji,jj,jk,jpdsi)  ) * 1.e6 
     219#else 
     220               zlam1b = 3.e-5 + xlam1 * (  trn(ji,jj,jk,jppoc)                   & 
     221                  &                      + trn(ji,jj,jk,jpcal) + trn(ji,jj,jk,jpdsi)  ) * 1.e6 
    188222#endif 
    189 C 
    190              END DO 
    191            END DO 
    192          END DO 
    193  
    194          DO jk = 1,jpkm1 
    195            DO jj = 1,jpj 
    196              DO ji = 1,jpi 
    197 C 
    198 C     Remineralization rate of BSi depedant on T and saturation 
    199 C     --------------------------------------------------------- 
    200 C 
    201          zsatur=(sio3eq(ji,jj,jk)-trn(ji,jj,jk,jpsil))/ 
    202      &     (sio3eq(ji,jj,jk)+rtrn) 
    203          zsatur=max(rtrn,zsatur) 
    204          zsatur2=zsatur*(1.+tn(ji,jj,jk)/400.)**4 
    205          znusil=0.225*(1.+tn(ji,jj,jk)/15.)*zsatur+0.775*zsatur2**9 
    206  
    207          siremin=xsirem*zstep*znusil 
    208 #    if defined key_off_degrad 
    209      &     *facvol(ji,jj,jk) 
    210 #    endif 
    211 C 
    212          osil(ji,jj,jk)=siremin*trn(ji,jj,jk,jpdsi) 
    213              END DO 
    214            END DO 
    215          END DO 
    216 C 
    217          fesatur(:,:,:)=0.6E-9 
    218 C 
    219          DO jk = 1,jpkm1 
    220            DO jj = 1,jpj 
    221              DO ji = 1,jpi 
    222 C 
    223 C     scavenging rate of iron. this scavenging rate depends on the 
    224 C     load in particles on which they are adsorbed. The 
    225 C     parameterization has been taken from studies on Th 
    226 C     ------------------------------------------------------------ 
    227 C 
    228          xkeq=fekeq(ji,jj,jk) 
    229          xfeequi=(-(1.+fesatur(ji,jj,jk)*xkeq-xkeq*trn(ji,jj,jk,jpfer))+ 
    230      &     sqrt((1.+fesatur(ji,jj,jk)*xkeq-xkeq*trn(ji,jj,jk,jpfer))**2 
    231      &     +4.*trn(ji,jj,jk,jpfer)*xkeq))/(2.*xkeq) 
    232  
     223# if defined key_off_degrad 
     224               xscave(ji,jj,jk) = zfeequi * zlam1b * zstep  * facvol(ji,jj,jk) 
     225# else 
     226               xscave(ji,jj,jk) = zfeequi * zlam1b * zstep 
     227# endif 
     228 
     229!  Increased scavenging for very high iron concentrations 
     230!  found near the coasts due to increased lithogenic particles 
     231!  and let s say it unknown processes (precipitation, ...) 
     232!  ----------------------------------------------------------- 
     233               zlamfac = MAX( 0.e0, ( gphit(ji,jj) + 55.) / 30. ) 
     234               zlamfac = MIN( 1.  , zlamfac ) 
    233235#if ! defined key_kriest 
    234          xlam1b=3E-5+xlam1*(trn(ji,jj,jk,jppoc) 
    235      &     +trn(ji,jj,jk,jpgoc)+trn(ji,jj,jk,jpcal)+ 
    236      &      trn(ji,jj,jk,jpdsi))*1E6 
    237 #else 
    238          xlam1b=3E-5+xlam1*(trn(ji,jj,jk,jppoc) 
    239      &     +trn(ji,jj,jk,jpcal)+trn(ji,jj,jk,jpdsi))*1E6 
     236               zlam1b = (  80.* ( trn(ji,jj,jk,jpdoc) + 35.e-6 )                           & 
     237                  &     + 698.*   trn(ji,jj,jk,jppoc) + 1.05e4 * trn(ji,jj,jk,jpgoc)  )                    & 
     238                  &   * zdiss(ji,jj,jk) + 1E-4 * (1.-zlamfac)                & 
     239                  &   + xlam1 * MAX( 0.e0, ( trn(ji,jj,jk,jpfer) * 1.e9 - 1.)  ) 
     240#else 
     241               zlam1b = (  80.* (trn(ji,jj,jk,jpdoc) + 35E-6)           & 
     242                  &     + 698.*  trn(ji,jj,jk,jppoc)  )                    & 
     243                  &   * zdiss(ji,jj,jk) + 1E-4 * (1.-zlamfac)           & 
     244                  &   + xlam1 * MAX( 0.e0, ( trn(ji,jj,jk,jpfer) * 1.e9 - 1.)  ) 
    240245#endif 
    241          xscave(ji,jj,jk)=xfeequi*xlam1b*zstep 
    242 #    if defined key_off_degrad 
    243      &     *facvol(ji,jj,jk) 
    244 #    endif 
    245 C 
    246 C  Increased scavenging for very high iron concentrations 
    247 C  found near the coasts due to increased lithogenic particles 
    248 C  and let's say it unknown processes (precipitation, ...) 
    249 C  ----------------------------------------------------------- 
    250 C 
    251          zlamfac=max(0.,(gphit(ji,jj)+55.)/30.) 
    252          zlamfac=min(1.,zlamfac) 
    253 #if ! defined key_kriest 
    254          xlam1b=(80.*(trn(ji,jj,jk,jpdoc)+35E-6)+698. 
    255      &    *trn(ji,jj,jk,jppoc)+1.05E4*trn(ji,jj,jk,jpgoc)) 
    256      &    *zdiss(ji,jj,jk)+1E-4*(1.-zlamfac)+xlam1*max(0., 
    257      &    (trn(ji,jj,jk,jpfer)*1E9-1.)) 
    258 #else 
    259          xlam1b=(80.*(trn(ji,jj,jk,jpdoc)+35E-6)+698. 
    260      &    *trn(ji,jj,jk,jppoc)) 
    261      &    *zdiss(ji,jj,jk)+1E-4*(1.-zlamfac)+xlam1*max(0., 
    262      &    (trn(ji,jj,jk,jpfer)*1E9-1.)) 
    263 #endif 
    264  
    265  
    266          xaggdfe(ji,jj,jk)=xlam1b*zstep*0.5*(trn(ji,jj,jk,jpfer) 
    267      &     -xfeequi) 
    268 #    if defined key_off_degrad 
    269      &     *facvol(ji,jj,jk) 
    270 #    endif 
    271  
    272 C 
    273              END DO 
    274            END DO 
    275          END DO 
    276 C 
    277 #endif 
    278       RETURN 
    279       END 
     246 
     247# if defined key_off_degrad 
     248               xaggdfe(ji,jj,jk) = zlam1b * zstep * 0.5 * ( trn(ji,jj,jk,jpfer) - zfeequi ) * facvol(ji,jj,jk) 
     249# else 
     250               xaggdfe(ji,jj,jk) = zlam1b * zstep * 0.5 * ( trn(ji,jj,jk,jpfer) - zfeequi ) 
     251# endif 
     252            END DO 
     253         END DO 
     254      END DO 
     255      ! 
     256   END SUBROUTINE p4z_rem 
     257 
     258#else 
     259   !!====================================================================== 
     260   !!  Dummy module :                                   No PISCES bio-model 
     261   !!====================================================================== 
     262CONTAINS 
     263   SUBROUTINE p4z_rem                    ! Empty routine 
     264   END SUBROUTINE p4z_rem 
     265#endif  
     266 
     267   !!====================================================================== 
     268END MODULE p4zrem 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zsed.F90

    r774 r775  
    1  
    2 CCC $Header: /home/opalod/NEMOCVSROOT/NEMO/TOP_SRC/SMS/p4zsed.F,v 1.9 2007/10/12 09:35:04 opalod Exp $  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6 CDIR$ LIST 
    7       SUBROUTINE p4zsed 
    8 #if defined key_top && defined key_pisces 
    9 CCC--------------------------------------------------------------------- 
    10 CCC 
    11 CCC          ROUTINE p4zsed : PISCES MODEL 
    12 CCC          ***************************** 
    13 CCC 
    14 CCC  PURPOSE : 
    15 CCC  --------- 
    16 CCC         Compute loss of organic matter in the sediments. This 
    17 CCC         is by no way a sediment model. The loss is simply  
    18 CCC         computed to balance the inout from rivers and dust 
    19 CCC 
    20 CC   INPUT : 
    21 CC   ----- 
    22 CC      common 
    23 CC              all the common defined in opa 
    24 CC 
    25 CC 
    26 CC   OUTPUT :                   : no 
    27 CC   ------ 
    28 CC 
    29 CC   EXTERNAL : 
    30 CC   -------- 
    31 CC             None 
    32 CC 
    33 CC   MODIFICATIONS: 
    34 CC   -------------- 
    35 CC      original  : 2004 - O. Aumont  
    36 CC---------------------------------------------------------------------- 
    37 CC parameters and commons 
    38 CC ====================== 
    39 CDIR$ NOLIST 
    40       USE oce_trc 
    41       USE trp_trc 
    42       USE sms 
    43       USE lib_mpp 
    44       IMPLICIT NONE 
    45 #include "domzgr_substitute.h90" 
    46 CDIR$ LIST 
    47 CC---------------------------------------------------------------------- 
    48 CC local declarations 
    49 CC ================== 
    50       INTEGER ji, jj, jk, ikt 
    51       REAL sumsedsi,sumsedpo4,sumsedcal 
    52       REAL xconctmp,denitot,nitrpottot,nitrpot(jpi,jpj,jpk) 
    53       REAL xlim,xconctmp2,zstep,zfact 
    54       REAL irondep(jpi,jpj,jpk),sidep(jpi,jpj) 
    55       REAL zvol 
    56 CC 
    57 C 
    58 C     Time step duration for the biology 
    59 C     ---------------------------------- 
    60 C 
    61         zstep=rfact2/rjjss 
    62 C 
    63 C 
    64 C     Initialisation of variables used to compute deposition 
    65 C     ------------------------------------------------------ 
    66 C 
    67       irondep     = 0. 
    68       sidep       = 0. 
    69 C 
    70 C     Iron and Si deposition at the surface 
    71 C     ------------------------------------- 
    72 C 
    73        do jj=1,jpj 
    74          do ji=1,jpi 
    75          irondep(ji,jj,1)=(0.014*dust(ji,jj)/(55.85*rmoss) 
    76      &      +3E-10/raass)*rfact2/fse3t(ji,jj,1) 
    77          sidep(ji,jj)=8.8*0.075*dust(ji,jj)*rfact2 
    78      &      /(fse3t(ji,jj,1)*28.1*rmoss) 
    79          end do 
    80        end do 
    81 C 
    82 C     Iron solubilization of particles in the water column 
    83 C     ---------------------------------------------------- 
    84 C 
    85       do jk=2,jpk-1 
    86         do jj=1,jpj 
    87           do ji=1,jpi 
    88           irondep(ji,jj,jk)=dust(ji,jj)/(10.*55.85*rmoss)*rfact2 
    89      &      *0.0001 
    90           end do 
    91         end do 
    92       end do 
    93 C 
    94 C    Add the external input of nutrients, carbon and alkalinity 
    95 C    ---------------------------------------------------------- 
    96 C 
    97         DO jj = 1,jpj 
    98           DO ji = 1,jpi 
    99           trn(ji,jj,1,jppo4) = trn(ji,jj,1,jppo4) 
    100      &      +rivinp(ji,jj)*rfact2 
    101           trn(ji,jj,1,jpno3) = trn(ji,jj,1,jpno3) 
    102      &      +(rivinp(ji,jj)+nitdep(ji,jj))*rfact2 
    103           trn(ji,jj,1,jpfer) = trn(ji,jj,1,jpfer) 
    104      &      +rivinp(ji,jj)*3E-5*rfact2 
    105           trn(ji,jj,1,jpsil) = trn(ji,jj,1,jpsil) 
    106      &      +sidep(ji,jj)+cotdep(ji,jj)*rfact2/6. 
    107           trn(ji,jj,1,jpdic) = trn(ji,jj,1,jpdic) 
    108      &      +rivinp(ji,jj)*rfact2*2.631 
    109           trn(ji,jj,1,jptal) = trn(ji,jj,1,jptal) 
    110      &      +(cotdep(ji,jj)-rno3*(rivinp(ji,jj) 
    111      &      +nitdep(ji,jj)))*rfact2 
    112           END DO 
    113         END DO 
    114 C 
    115  
    116 C 
    117 C     Add the external input of iron which is 3D distributed 
    118 C     (dust, river and sediment mobilization) 
    119 C     ------------------------------------------------------ 
    120 C 
    121         DO jk=1,jpkm1 
    122           DO jj=1,jpj 
    123             DO ji=1,jpi 
    124           trn(ji,jj,jk,jpfer) = trn(ji,jj,jk,jpfer) 
    125      &      +irondep(ji,jj,jk)+ironsed(ji,jj,jk)*rfact2 
    126             END DO 
    127           END DO 
    128         END DO 
    129 C 
    130 C     Initialisation of variables used to compute Sinking Speed 
    131 C     --------------------------------------------------------- 
    132 C 
    133         sumsedsi = 0. 
    134         sumsedpo4 = 0. 
    135         sumsedcal = 0. 
    136 C 
    137 C    Loss of biogenic silicon, Caco3 organic carbon in the sediments.  
    138 C    First, the total loss is computed. 
    139 C    The factor for calcite comes from the alkalinity effect 
    140 C    ------------------------------------------------------------- 
    141 C 
    142         DO jj=1,jpj 
    143           DO ji=1,jpi 
    144             ikt=max(mbathy(ji,jj)-1,1) 
    145             zfact=e1t(ji,jj)*e2t(ji,jj)/rjjss*tmask_i(ji,jj) 
    146             sumsedsi=sumsedsi+zfact*trn(ji,jj,ikt,jpdsi) 
    147 #if ! defined key_kriest 
    148      &               *wsbio4(ji,jj,ikt)  
     1MODULE p4zsed 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4sed  *** 
     4   !! TOP :   PISCES Compute loss of organic matter in the sediments 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004-03 (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_sed        :  Compute loss of organic matter in the sediments 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc 
     17   USE sms 
     18   USE lib_mpp 
     19 
     20   IMPLICIT NONE 
     21   PRIVATE 
     22 
     23   PUBLIC   p4z_sed    ! called in p4zprg.F90 
     24 
     25   !!* Substitution 
     26#  include "domzgr_substitute.h90" 
     27   !!---------------------------------------------------------------------- 
     28   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     29   !! $Header:$  
     30   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     31   !!---------------------------------------------------------------------- 
     32 
     33CONTAINS 
     34 
     35   SUBROUTINE p4z_sed 
     36      !!--------------------------------------------------------------------- 
     37      !!                     ***  ROUTINE p4z_sed  *** 
     38      !! 
     39      !! ** Purpose :   Compute loss of organic matter in the sediments. This 
     40      !!              is by no way a sediment model. The loss is simply  
     41      !!              computed to balance the inout from rivers and dust 
     42      !! 
     43      !! ** Method  : - ??? 
     44      !!--------------------------------------------------------------------- 
     45      INTEGER  ::   ji, jj, jk 
     46      INTEGER  ::   ikt 
     47      REAL(wp) ::   zsumsedsi, zsumsedpo4, zsumsedcal 
     48      REAL(wp) ::   zconctmp , zdenitot  , znitrpottot 
     49      REAL(wp) ::   zlim, zconctmp2, zstep, zfact 
     50      REAL(wp), DIMENSION(jpi,jpj)     ::   zsidep 
     51      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   znitrpot, zirondep 
     52      !!--------------------------------------------------------------------- 
     53 
     54 
     55      zstep = rfact2 / rjjss      ! Time step duration for the biology 
     56 
     57      zirondep(:,:,:) = 0.e0          ! Initialisation of variables used to compute deposition 
     58      zsidep  (:,:)   = 0.e0 
     59 
     60      ! Iron and Si deposition at the surface 
     61      ! ------------------------------------- 
     62 
     63      DO jj = 1, jpj 
     64         DO ji = 1, jpi 
     65            zirondep(ji,jj,1) = ( 0.014 * dust(ji,jj) / ( 55.85 * rmoss ) + 3.e-10 / raass )   & 
     66               &             * rfact2 / fse3t(ji,jj,1) 
     67            zsidep  (ji,jj)   = 8.8 * 0.075 * dust(ji,jj) * rfact2 / ( fse3t(ji,jj,1) * 28.1 * rmoss ) 
     68         END DO 
     69      END DO 
     70 
     71      ! Iron solubilization of particles in the water column 
     72      ! ---------------------------------------------------- 
     73 
     74      DO jk = 2, jpkm1 
     75         DO jj = 1, jpj 
     76            DO ji = 1, jpi 
     77               zirondep(ji,jj,jk) = dust(ji,jj) / ( 10. * 55.85 * rmoss ) * rfact2 * 0.0001 
     78            END DO 
     79         END DO 
     80      END DO 
     81 
     82      ! Add the external input of nutrients, carbon and alkalinity 
     83      ! ---------------------------------------------------------- 
     84 
     85      DO jj = 1, jpj 
     86         DO ji = 1, jpi 
     87            trn(ji,jj,1,jppo4) = trn(ji,jj,1,jppo4) +   rivinp(ji,jj)                   * rfact2 
     88            trn(ji,jj,1,jpno3) = trn(ji,jj,1,jpno3) + ( rivinp(ji,jj) + nitdep(ji,jj) ) * rfact2 
     89            trn(ji,jj,1,jpfer) = trn(ji,jj,1,jpfer) +   rivinp(ji,jj) * 3.e-5           * rfact2 
     90            trn(ji,jj,1,jpsil) = trn(ji,jj,1,jpsil) +   zsidep (ji,jj) + cotdep(ji,jj)   * rfact2 / 6. 
     91            trn(ji,jj,1,jpdic) = trn(ji,jj,1,jpdic) +   rivinp(ji,jj) * 2.631           * rfact2 
     92            trn(ji,jj,1,jptal) = trn(ji,jj,1,jptal) + ( cotdep(ji,jj) - rno3*(rivinp(ji,jj)   & 
     93               &                                                      + nitdep(ji,jj) ) ) * rfact2 
     94         END DO 
     95      END DO 
     96 
     97 
     98      ! Add the external input of iron which is 3D distributed 
     99      ! (dust, river and sediment mobilization) 
     100      ! ------------------------------------------------------ 
     101 
     102      DO jk = 1, jpkm1 
     103         DO jj = 1, jpj 
     104            DO ji = 1, jpi 
     105               trn(ji,jj,jk,jpfer) = trn(ji,jj,jk,jpfer)   & 
     106                  &                + zirondep(ji,jj,jk) + ironsed(ji,jj,jk) * rfact2 
     107            END DO 
     108         END DO 
     109      END DO 
     110 
     111      ! Initialisation of variables used to compute Sinking Speed 
     112      ! --------------------------------------------------------- 
     113 
     114      zsumsedsi  = 0.e0 
     115      zsumsedpo4 = 0.e0 
     116      zsumsedcal = 0.e0 
     117 
     118      ! Loss of biogenic silicon, Caco3 organic carbon in the sediments.  
     119      ! First, the total loss is computed. 
     120      ! The factor for calcite comes from the alkalinity effect 
     121      ! ------------------------------------------------------------- 
     122 
     123      DO jj = 1, jpj 
     124         DO ji = 1, jpi 
     125            ikt = MAX( mbathy(ji,jj)-1, 1 ) 
     126            zfact = e1t(ji,jj) * e2t(ji,jj) / rjjss * tmask_i(ji,jj) 
     127# if ! defined key_kriest 
     128            zsumsedsi  = zsumsedsi  + zfact *  trn(ji,jj,ikt,jpdsi) * wsbio4(ji,jj,ikt)  
     129# else 
     130            zsumsedsi  = zsumsedsi  + zfact *  trn(ji,jj,ikt,jpdsi) * wscal (ji,jj,ikt) 
     131# endif 
     132            zsumsedcal = zsumsedcal + zfact *  trn(ji,jj,ikt,jpcal) * wscal (ji,jj,ikt) * 2.e0 
     133# if  defined key_kriest 
     134            zsumsedpo4 = zsumsedpo4 + zfact *  trn(ji,jj,ikt,jppoc) * wsbio3(ji,jj,ikt) 
     135# else 
     136            zsumsedpo4 = zsumsedpo4 + zfact *( trn(ji,jj,ikt,jpgoc) * wsbio4(ji,jj,ikt)   & 
     137               &                             + trn(ji,jj,ikt,jppoc) * wsbio3(ji,jj,ikt) ) 
     138# endif 
     139         END DO 
     140      END DO 
     141 
     142      IF( lk_mpp ) THEN 
     143         CALL mpp_sum( zsumsedsi  )   ! sums over the global domain 
     144         CALL mpp_sum( zsumsedcal )   ! sums over the global domain 
     145         CALL mpp_sum( zsumsedpo4 )   ! sums over the global domain 
     146      ENDIF 
     147 
     148      ! Then this loss is scaled at each bottom grid cell for 
     149      ! equilibrating the total budget of silica in the ocean. 
     150      ! Thus, the amount of silica lost in the sediments equal 
     151      ! the supply at the surface (dust+rivers) 
     152      ! ------------------------------------------------------ 
     153 
     154      DO jj = 1, jpj 
     155         DO ji = 1, jpi 
     156            ikt = MAX( mbathy(ji,jj) - 1, 1 ) 
     157            zconctmp = trn(ji,jj,ikt,jpdsi) * zstep / fse3t(ji,jj,ikt)   & 
     158# if ! defined key_kriest 
     159     &               * wsbio4(ji,jj,ikt)  
     160# else 
     161     &               * wscal (ji,jj,ikt) 
     162# endif 
     163            trn(ji,jj,ikt,jpdsi) = trn(ji,jj,ikt,jpdsi) - zconctmp 
     164            trn(ji,jj,ikt,jpsil) = trn(ji,jj,ikt,jpsil) + zconctmp   & 
     165               &                 * ( 1.- ( sumdepsi + rivalkinput / raass / 6. ) / zsumsedsi ) 
     166         END DO 
     167      END DO 
     168 
     169      DO jj = 1, jpj 
     170         DO ji = 1, jpi 
     171            ikt = MAX( mbathy(ji,jj) - 1, 1 ) 
     172            zconctmp = trn(ji,jj,ikt,jpcal) * wscal(ji,jj,ikt) * zstep / fse3t(ji,jj,ikt) 
     173            trn(ji,jj,ikt,jpcal) = trn(ji,jj,ikt,jpcal) - zconctmp 
     174            trn(ji,jj,ikt,jptal) = trn(ji,jj,ikt,jptal) + zconctmp   & 
     175               &                 * ( 1.- ( rivalkinput / raass ) / zsumsedcal ) * 2.e0 
     176            trn(ji,jj,ikt,jpdic) = trn(ji,jj,ikt,jpdic) + zconctmp   & 
     177               &                 * ( 1.- ( rivalkinput / raass ) / zsumsedcal ) 
     178         END DO 
     179      END DO 
     180 
     181      DO jj = 1, jpj 
     182         DO ji = 1, jpi 
     183            ikt = MAX( mbathy(ji,jj) - 1, 1 ) 
     184# if ! defined key_kriest 
     185            zconctmp  = trn(ji,jj,ikt,jpgoc) 
     186            zconctmp2 = trn(ji,jj,ikt,jppoc) 
     187            trn(ji,jj,ikt,jpgoc) = trn(ji,jj,ikt,jpgoc) - zconctmp  * wsbio4(ji,jj,ikt)   * zstep / fse3t(ji,jj,ikt) 
     188            trn(ji,jj,ikt,jppoc) = trn(ji,jj,ikt,jppoc) - zconctmp2 * wsbio3(ji,jj,ikt)   * zstep / fse3t(ji,jj,ikt) 
     189            trn(ji,jj,ikt,jpdoc) = trn(ji,jj,ikt,jpdoc)    & 
     190               &      + ( zconctmp  * wsbio4(ji,jj,ikt) + zconctmp2 * wsbio3(ji,jj,ikt) ) * zstep / fse3t(ji,jj,ikt)   & 
     191               &                                        * ( 1.- rivpo4input / (raass * zsumsedpo4 ) ) 
     192            trn(ji,jj,ikt,jpbfe) = trn(ji,jj,ikt,jpbfe) - trn(ji,jj,ikt,jpbfe) * wsbio4(ji,jj,ikt) * zstep   & 
     193               &          /fse3t(ji,jj,ikt) 
     194            trn(ji,jj,ikt,jpsfe) = trn(ji,jj,ikt,jpsfe) - trn(ji,jj,ikt,jpsfe) * wsbio3(ji,jj,ikt) * zstep   & 
     195               &          /fse3t(ji,jj,ikt) 
     196# else 
     197            zconctmp  = trn(ji,jj,ikt,jpnum) 
     198            zconctmp2 = trn(ji,jj,ikt,jppoc) 
     199            trn(ji,jj,ikt,jpnum) = trn(ji,jj,ikt,jpnum)   & 
     200               &          - zconctmp * wsbio4(ji,jj,ikt) * zstep / fse3t(ji,jj,ikt) 
     201            trn(ji,jj,ikt,jppoc) = trn(ji,jj,ikt,jppoc)   & 
     202               &          - zconctmp2 * wsbio3(ji,jj,ikt) * zstep / fse3t(ji,jj,ikt) 
     203            trn(ji,jj,ikt,jpdoc) = trn(ji,jj,ikt,jpdoc)    & 
     204               &          + ( zconctmp2 * wsbio3(ji,jj,ikt) )   & 
     205               &          * zstep / fse3t(ji,jj,ikt) * ( 1.- rivpo4input / ( raass * zsumsedpo4 ) ) 
     206            trn(ji,jj,ikt,jpsfe) = trn(ji,jj,ikt,jpsfe)   & 
     207               &                 - trn(ji,jj,ikt,jpsfe) * wsbio3(ji,jj,ikt) * zstep / fse3t(ji,jj,ikt) 
     208# endif 
     209         END DO 
     210      END DO 
     211 
     212      ! Nitrogen fixation (simple parameterization). The total gain 
     213      ! from nitrogen fixation is scaled to balance the loss by  
     214      ! denitrification 
     215      ! ------------------------------------------------------------- 
     216 
     217!!gm optimisation : use fs do loop index... or 1 to jpi/j 
     218      zdenitot = 0.e0 
     219      DO jk = 1, jpkm1 
     220         DO jj= 2, jpjm1 
     221            DO ji = 2, jpim1 
     222               zdenitot = zdenitot + denitr(ji,jj,jk) * rdenit * e1t(ji,jj) * e2t(ji,jj)   & 
     223                  &    *fse3t(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) * znegtr(ji,jj,jk) 
     224            END DO 
     225         END DO 
     226      END DO 
     227 
     228      IF( lk_mpp )   CALL mpp_sum( zdenitot )      ! sum over the global domain 
     229 
     230      ! Potential nitrogen fication dependant on temperature and iron 
     231      ! ------------------------------------------------------------- 
     232 
     233      DO jk = 1, jpk 
     234         DO jj = 1, jpj 
     235            DO ji = 1, jpi 
     236               zlim = ( 1.- xnanono3(ji,jj,jk) - xnanonh4(ji,jj,jk) ) 
     237               IF( zlim <= 0.2 )   zlim = 0.01 
     238               znitrpot(ji,jj,jk) = MAX( 0.e0, ( 0.6 * tgfunc(ji,jj,jk) - 2.15 ) / rjjss )   & 
     239# if defined key_off_degrad 
     240                  &               * facvol(ji,jj,jk)   & 
     241# endif 
     242                  &               * zlim * rfact2 * trn(ji,jj,jk,jpfer)   & 
     243                  &               / ( conc3 + trn(ji,jj,jk,jpfer) ) * ( 1.- EXP( -etot(ji,jj,jk) / 50.) ) 
     244            END DO 
     245         END DO  
     246      END DO 
     247 
     248      znitrpottot = 0.e0 
     249      DO jk = 1, jpkm1 
     250         DO jj = 1, jpj 
     251            DO ji = 1, jpi 
     252               znitrpottot = znitrpottot + znitrpot(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)   & 
     253                  &                                           * tmask(ji,jj,jk) * tmask_i(ji,jj)  
     254            END DO 
     255         END DO 
     256      END DO 
     257 
     258      IF( lk_mpp )   CALL mpp_sum( znitrpottot )  ! sum over the global domain 
     259 
     260      ! Nitrogen change due to nitrogen fixation 
     261      ! ---------------------------------------- 
     262 
     263      DO jk = 1, jpk 
     264         DO jj = 1, jpj 
     265            DO ji = 1, jpi 
     266# if ! defined key_cfg_1d && ( defined key_orca_r4 || defined key_orca_r2 || defined key_orca_r05 || defined key_orca_r025 ) 
     267               zfact = znitrpot(ji,jj,jk) * zdenitot / znitrpottot 
     268# else 
     269               zfact = znitrpot(ji,jj,jk) * 1.e-7 
     270# endif 
     271               trn(ji,jj,jk,jpnh4) = trn(ji,jj,jk,jpnh4) + zfact 
     272               trn(ji,jj,jk,jpoxy) = trn(ji,jj,jk,jpoxy) + zfact   * o2nit 
     273               trn(ji,jj,jk,jppo4) = trn(ji,jj,jk,jppo4) + 30./ 46.* zfact 
     274            END DO 
     275         END DO 
     276      END DO 
     277 
     278# if defined key_trc_diaadd 
     279      DO jj = 1,jpj 
     280         DO ji = 1,jpi 
     281            trc2d(ji,jj,13) = znitrpot(ji,jj,1) * 1.e-7 * fse3t(ji,jj,1) * 1.e+3 / rfact2 
     282            trc2d(ji,jj,12) = zirondep(ji,jj,1) * 1.e+3 * rfact2r * fse3t(ji,jj,1) 
     283         END DO 
     284      END DO 
     285# endif 
     286      ! 
     287   END SUBROUTINE p4z_sed 
     288 
    149289#else 
    150      &               *wscal(ji,jj,ikt) 
    151 #endif 
    152             sumsedcal=sumsedcal+trn(ji,jj,ikt,jpcal)*wscal(ji,jj,ikt) 
    153      &          *2.*zfact 
    154 #if  defined key_kriest 
    155             sumsedpo4=sumsedpo4+ 
    156      &          (trn(ji,jj,ikt,jppoc)*wsbio3(ji,jj,ikt))*zfact 
    157 #else 
    158             sumsedpo4=sumsedpo4+(trn(ji,jj,ikt,jpgoc)*wsbio4(ji,jj,ikt) 
    159      &    +trn(ji,jj,ikt,jppoc)*wsbio3(ji,jj,ikt))*zfact 
    160 #endif 
    161           END DO 
    162         END DO 
    163  
    164          IF( lk_mpp ) THEN 
    165             CALL mpp_sum( sumsedsi )   ! sums over the global domain 
    166             CALL mpp_sum( sumsedcal )   ! sums over the global domain 
    167             CALL mpp_sum( sumsedpo4 )   ! sums over the global domain 
    168          ENDIF 
    169 C 
    170 C    Then this loss is scaled at each bottom grid cell for 
    171 C    equilibrating the total budget of silica in the ocean. 
    172 C    Thus, the amount of silica lost in the sediments equal 
    173 C    the supply at the surface (dust+rivers) 
    174 C    ------------------------------------------------------ 
    175 C 
    176         DO jj=1,jpj 
    177           DO ji=1,jpi 
    178             ikt=max(mbathy(ji,jj)-1,1) 
    179             xconctmp=trn(ji,jj,ikt,jpdsi)*zstep/fse3t(ji,jj,ikt) 
    180 #if ! defined key_kriest 
    181      &               *wsbio4(ji,jj,ikt)  
    182 #else 
    183      &               *wscal(ji,jj,ikt) 
    184 #endif 
    185             trn(ji,jj,ikt,jpdsi)=trn(ji,jj,ikt,jpdsi)-xconctmp 
    186             trn(ji,jj,ikt,jpsil)=trn(ji,jj,ikt,jpsil)+xconctmp 
    187      &          *(1.-(sumdepsi+rivalkinput/raass/6.)/sumsedsi) 
    188           END DO 
    189         END DO 
    190  
    191         DO jj=1,jpj 
    192           DO ji=1,jpi 
    193             ikt=max(mbathy(ji,jj)-1,1) 
    194             xconctmp=trn(ji,jj,ikt,jpcal)*wscal(ji,jj,ikt)*zstep 
    195      &          /fse3t(ji,jj,ikt) 
    196             trn(ji,jj,ikt,jpcal)=trn(ji,jj,ikt,jpcal)-xconctmp 
    197             trn(ji,jj,ikt,jptal)=trn(ji,jj,ikt,jptal)+xconctmp 
    198      &          *(1.-(rivalkinput/raass)/sumsedcal)*2. 
    199             trn(ji,jj,ikt,jpdic)=trn(ji,jj,ikt,jpdic)+xconctmp 
    200      &          *(1.-(rivalkinput/raass)/sumsedcal) 
    201           END DO 
    202         END DO 
    203  
    204         DO jj=1,jpj 
    205           DO ji=1,jpi 
    206             ikt=max(mbathy(ji,jj)-1,1) 
    207 #if ! defined key_kriest 
    208             xconctmp=trn(ji,jj,ikt,jpgoc) 
    209             xconctmp2=trn(ji,jj,ikt,jppoc) 
    210             trn(ji,jj,ikt,jpgoc)=trn(ji,jj,ikt,jpgoc) 
    211      &          -xconctmp*wsbio4(ji,jj,ikt)*zstep/fse3t(ji,jj,ikt) 
    212             trn(ji,jj,ikt,jppoc)=trn(ji,jj,ikt,jppoc) 
    213      &          -xconctmp2*wsbio3(ji,jj,ikt)*zstep/fse3t(ji,jj,ikt) 
    214             trn(ji,jj,ikt,jpdoc)=trn(ji,jj,ikt,jpdoc) 
    215      &          +(xconctmp*wsbio4(ji,jj,ikt)+xconctmp2*wsbio3(ji,jj,ikt) 
    216      $          )*zstep/fse3t(ji,jj,ikt)*(1.-rivpo4input/(raass 
    217      $          *sumsedpo4)) 
    218             trn(ji,jj,ikt,jpbfe)=trn(ji,jj,ikt,jpbfe) 
    219      &          -trn(ji,jj,ikt,jpbfe)*wsbio4(ji,jj,ikt)*zstep 
    220      &          /fse3t(ji,jj,ikt) 
    221             trn(ji,jj,ikt,jpsfe)=trn(ji,jj,ikt,jpsfe) 
    222      &          -trn(ji,jj,ikt,jpsfe)*wsbio3(ji,jj,ikt)*zstep 
    223      &          /fse3t(ji,jj,ikt) 
    224 #else 
    225             xconctmp=trn(ji,jj,ikt,jpnum) 
    226             xconctmp2=trn(ji,jj,ikt,jppoc) 
    227             trn(ji,jj,ikt,jpnum)=trn(ji,jj,ikt,jpnum) 
    228      &          -xconctmp*wsbio4(ji,jj,ikt)*zstep/fse3t(ji,jj,ikt) 
    229             trn(ji,jj,ikt,jppoc)=trn(ji,jj,ikt,jppoc) 
    230      &          -xconctmp2*wsbio3(ji,jj,ikt)*zstep/fse3t(ji,jj,ikt) 
    231             trn(ji,jj,ikt,jpdoc)=trn(ji,jj,ikt,jpdoc) 
    232      &          +(xconctmp2*wsbio3(ji,jj,ikt)) 
    233      $          *zstep/fse3t(ji,jj,ikt)*(1.-rivpo4input/(raass 
    234      $          *sumsedpo4)) 
    235             trn(ji,jj,ikt,jpsfe)=trn(ji,jj,ikt,jpsfe) 
    236      &          -trn(ji,jj,ikt,jpsfe)*wsbio3(ji,jj,ikt)*zstep 
    237      &          /fse3t(ji,jj,ikt) 
    238  
    239 #endif 
    240           END DO 
    241         END DO 
    242 C 
    243 C  Nitrogen fixation (simple parameterization). The total gain 
    244 C  from nitrogen fixation is scaled to balance the loss by  
    245 C  denitrification 
    246 C  ------------------------------------------------------------- 
    247 C 
    248         denitot=0. 
    249         DO jk=1,jpk-1 
    250           DO jj=2,jpj-1 
    251             DO ji=2,jpi-1 
    252         denitot=denitot+denitr(ji,jj,jk)*rdenit*e1t(ji,jj)*e2t(ji,jj) 
    253      &    *fse3t(ji,jj,jk)*tmask(ji,jj,jk)*tmask_i(ji,jj) 
    254      &    *znegtr(ji,jj,jk) 
    255             END DO 
    256           END DO 
    257         END DO 
    258  
    259         IF( lk_mpp )   CALL mpp_sum( denitot )  ! sum over the global domain 
    260 C 
    261 C  Potential nitrogen fication dependant on temperature 
    262 C  and iron 
    263 C  ---------------------------------------------------- 
    264 C 
    265        DO jk=1,jpk 
    266         DO jj=1,jpj 
    267           DO ji=1,jpi 
    268         xlim=(1.-xnanono3(ji,jj,jk)-xnanonh4(ji,jj,jk)) 
    269         if (xlim.le.0.2) xlim=0.01 
    270         nitrpot(ji,jj,jk)=max(0.,(0.6*tgfunc(ji,jj,jk)-2.15)/rjjss) 
    271 #if defined key_off_degrad 
    272      &    *facvol(ji,jj,jk) 
    273 #endif 
    274      &    *xlim*rfact2*trn(ji,jj,jk,jpfer)/(conc3 
    275      &    +trn(ji,jj,jk,jpfer))*(1.-exp(-etot(ji,jj,jk)/50.)) 
    276           END DO 
    277         END DO  
    278        END DO 
    279 C 
    280       nitrpottot=0. 
    281       DO jk=1,jpkm1 
    282         DO jj=1,jpj 
    283           DO ji=1,jpi 
    284         nitrpottot=nitrpottot+nitrpot(ji,jj,jk)*e1t(ji,jj) 
    285      &    *e2t(ji,jj)*tmask(ji,jj,jk)*tmask_i(ji,jj)*fse3t(ji,jj,jk) 
    286           END DO 
    287         END DO 
    288       END DO 
    289  
    290         IF( lk_mpp )   CALL mpp_sum( nitrpottot )  ! sum over the global domain 
    291 C 
    292 C  Nitrogen change due to nitrogen fixation 
    293 C  ---------------------------------------- 
    294 C 
    295        DO jk=1,jpk 
    296         DO jj=1,jpj 
    297           DO ji=1,jpi 
    298 #if ! defined key_cfg_1d && ( defined key_orca_r4 || defined key_orca_r2 || defined key_orca_r05 || defined key_orca_r025 ) 
    299         zfact=nitrpot(ji,jj,jk)*denitot/nitrpottot 
    300 #else 
    301         zfact=nitrpot(ji,jj,jk)*1.E-7 
    302 #endif 
    303         trn(ji,jj,jk,jpnh4)=trn(ji,jj,jk,jpnh4)+zfact 
    304         trn(ji,jj,jk,jpoxy)=trn(ji,jj,jk,jpoxy)+zfact*o2nit 
    305         trn(ji,jj,jk,jppo4)=trn(ji,jj,jk,jppo4)+30./46.*zfact 
    306           END DO 
    307         END DO 
    308        END DO 
    309 C 
    310 #    if defined key_trc_diaadd 
    311         DO jj = 1,jpj 
    312           DO ji = 1,jpi 
    313         trc2d(ji,jj,13) = nitrpot(ji,jj,1)*1E-7*fse3t(ji,jj,1)*1E3 
    314      &    /rfact2 
    315         trc2d(ji,jj,12) = irondep(ji,jj,1)*1e3*rfact2r 
    316      &    *fse3t(ji,jj,1) 
    317           END DO 
    318         END DO 
    319 #    endif 
    320 C 
    321 #endif 
    322       RETURN 
    323       END 
     290   !!====================================================================== 
     291   !!  Dummy module :                                   No PISCES bio-model 
     292   !!====================================================================== 
     293CONTAINS 
     294   SUBROUTINE p4z_sed                         ! Empty routine 
     295   END SUBROUTINE p4z_sed 
     296#endif  
     297 
     298   !!====================================================================== 
     299END MODULE  p4zsed 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zsink.F90

    r774 r775  
    1       SUBROUTINE p4zsink 
    2 #if defined key_top && defined key_pisces 
    3 CCC--------------------------------------------------------------------- 
    4 CCC 
    5 CCC          ROUTINE p4zsink : PISCES MODEL 
    6 CCC          ****************************** 
    7 CCC 
    8 CCC  PURPOSE : 
    9 CCC  --------- 
    10 CCC         Compute vertical flux of particulate matter due to 
    11 CCC         gravitational sinking 
    12 CCC 
    13 CC   INPUT : 
    14 CC   ----- 
    15 CC      common 
    16 CC              all the common defined in opa 
    17 CC 
    18 CC 
    19 CC   OUTPUT :                   : no 
    20 CC   ------ 
    21 CC 
    22 CC   EXTERNAL : 
    23 CC   -------- 
    24 CC            p4zsink2 
    25 CC 
    26 CC   MODIFICATIONS: 
    27 CC   -------------- 
    28 CC      original  : 2004 - O. Aumont  
    29 CC---------------------------------------------------------------------- 
    30 CC parameters and commons 
    31 CC ====================== 
    32 CDIR$ NOLIST 
    33       USE oce_trc 
    34       USE trp_trc 
    35       USE sms 
    36       IMPLICIT NONE 
    37 #include "domzgr_substitute.h90" 
    38  
    39 #if defined key_kriest 
    40  
    41 # include "p4zsink.kriest.h" 
     1MODULE p4zsink 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zsink  *** 
     4   !! TOP :   PISCES Compute vertical flux of particulate matter due to gravitational sinking 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces  && ! defined key_kriest 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'        and                            PISCES bio-model 
     12   !!   NOT 'key_kriest'                                   No Kriest option 
     13   !!---------------------------------------------------------------------- 
     14   !!   p4z_sink       :  Compute vertical flux of particulate matter due to gravitational sinking 
     15   !!---------------------------------------------------------------------- 
     16   USE oce_trc         ! 
     17   USE trp_trc 
     18   USE sms 
     19   USE p4zsink2        ! 
     20 
     21   IMPLICIT NONE 
     22   PRIVATE 
     23 
     24   PUBLIC   p4z_sink    ! called in p4zbio.F90 
     25 
     26   !!* Substitution 
     27#  include "domzgr_substitute.h90" 
     28   !!---------------------------------------------------------------------- 
     29   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     30   !! $Header:$  
     31   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     32   !!---------------------------------------------------------------------- 
     33 
     34CONTAINS 
     35 
     36   SUBROUTINE p4z_sink 
     37      !!--------------------------------------------------------------------- 
     38      !!                     ***  ROUTINE p4z_sink  *** 
     39      !! 
     40      !! ** Purpose :   Compute vertical flux of particulate matter due to  
     41      !!              gravitational sinking 
     42      !! 
     43      !! ** Method  : - ??? 
     44      !!--------------------------------------------------------------------- 
     45      INTEGER  ::   ji, jj, jk 
     46      INTEGER  ::   iksed 
     47      REAL(wp) ::   zagg1, zagg2, zagg3, zagg4 
     48      REAL(wp) ::   zfact, zstep, zwsmax 
     49#if defined key_trc_dia3d 
     50      REAL(wp) ::   zrfact2 
     51#endif 
     52      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zsinking, zsinking2 
     53      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zsinkfer, zsinkfer2 
     54      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zsinkcal, zsinksil 
     55      !!--------------------------------------------------------------------- 
     56 
     57       zstep = rfact2 / rjjss      ! Timestep duration for biology 
     58 
     59 
     60!    Sinking speeds of detritus is increased with depth as shown 
     61!    by data and from the coagulation theory 
     62!    ----------------------------------------------------------- 
     63 
     64      iksed = 10 
     65 
     66      DO jk = 1, jpkm1 
     67         DO jj = 1, jpj 
     68            DO ji=1,jpi 
     69               zfact = MAX( 0., fsdepw(ji,jj,jk+1)-hmld(ji,jj) ) / 4000. 
     70               wsbio4(ji,jj,jk) = wsbio2 + ( 200.- wsbio2 ) * zfact 
     71            END DO 
     72         END DO 
     73      END DO 
     74 
     75!      LIMIT THE VALUES OF THE SINKING SPEEDS  
     76!      TO AVOID NUMERICAL INSTABILITIES 
     77 
     78      wsbio3(:,:,:) = wsbio 
     79 
     80      DO jk = 1,jpkm1 
     81         DO jj = 1, jpj 
     82            DO ji = 1, jpi 
     83               zwsmax = 0.8 * fse3t(ji,jj,jk) / zstep 
     84               wsbio4(ji,jj,jk) = MIN( wsbio4(ji,jj,jk), zwsmax ) 
     85               wsbio3(ji,jj,jk) = MIN( wsbio3(ji,jj,jk), zwsmax ) 
     86            END DO 
     87         END DO 
     88      END DO 
     89 
     90      wscal(:,:,:) = wsbio4(:,:,:) 
     91 
     92 
     93!   INITIALIZE TO ZERO ALL THE SINKING ARRAYS 
     94!   ----------------------------------------- 
     95 
     96      zsinking (:,:,:) = 0.e0 
     97      zsinking2(:,:,:) = 0.e0 
     98      zsinkcal (:,:,:) = 0.e0 
     99      zsinkfer (:,:,:) = 0.e0 
     100      zsinksil (:,:,:) = 0.e0 
     101      zsinkfer2(:,:,:) = 0.e0 
     102 
     103!   Compute the sedimentation term using p4zsink2 for all 
     104!   the sinking particles 
     105!   ----------------------------------------------------- 
     106 
     107      CALL p4z_sink2( wsbio3, zsinking , jppoc ) 
     108      CALL p4z_sink2( wsbio3, zsinkfer , jpsfe ) 
     109      CALL p4z_sink2( wsbio4, zsinking2, jpgoc ) 
     110      CALL p4z_sink2( wsbio4, zsinkfer2, jpbfe ) 
     111      CALL p4z_sink2( wsbio4, zsinksil , jpdsi ) 
     112      CALL p4z_sink2( wscal , zsinkcal , jpcal ) 
     113 
     114!  Exchange between organic matter compartments due to 
     115!  coagulation/disaggregation 
     116!  --------------------------------------------------- 
     117 
     118      DO jk = 1, jpkm1 
     119         DO jj = 1, jpj 
     120            DO ji = 1, jpi 
     121 
     122               zfact = zstep * zdiss(ji,jj,jk) 
     123 
     124!    Part I : Coagulation dependent on turbulence 
     125!    ---------------------------------------------- 
     126 
     127# if defined key_off_degrad 
     128               zagg1 = 940.* zfact * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jppoc) * facvol(ji,jj,jk) 
     129# else 
     130               zagg1 = 940.* zfact * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jppoc) 
     131# endif 
     132 
     133# if defined key_off_degrad 
     134               zagg2 = 1.054e4 * zfact * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpgoc) * facvol(ji,jj,jk) 
     135# else 
     136               zagg2 = 1.054e4 * zfact * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpgoc) 
     137# endif 
     138 
     139!    Aggregation of small into large particles 
     140!    Part II : Differential settling 
     141!    ---------------------------------------------- 
     142 
     143# if defined key_off_degrad 
     144               zagg3 = 0.66 * zstep * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpgoc) * facvol(ji,jj,jk) 
     145# else 
     146               zagg3 = 0.66 * zstep * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jpgoc) 
     147# endif 
     148 
     149# if defined key_off_degrad 
     150!!gm  zagg4 set to zero ???? 
     151               zagg4 = 0.e0 * zstep * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jppoc) * facvol(ji,jj,jk) 
     152# else 
     153!!gm  zagg4 set to zero ???? 
     154               zagg4 = 0.e0 * zstep * trn(ji,jj,jk,jppoc) * trn(ji,jj,jk,jppoc) 
     155# endif 
     156 
     157               xagg  (ji,jj,jk) = zagg1 + zagg2 + zagg3 + zagg4 
     158               xaggfe(ji,jj,jk) = xagg(ji,jj,jk) * trn(ji,jj,jk,jpsfe) / ( trn(ji,jj,jk,jppoc) + rtrn ) 
     159 
     160!     Aggregation of DOC to small particles 
     161!     -------------------------------------- 
     162 
     163               xaggdoc(ji,jj,jk) = ( 80.* trn(ji,jj,jk,jpdoc) + 698. * trn(ji,jj,jk,jppoc) )       & 
     164# if defined key_off_degrad 
     165                  &              * facvol(ji,jj,jk)                           & 
     166# endif 
     167                  &              * zfact * trn(ji,jj,jk,jpdoc) 
     168 
     169               xaggdoc2(ji,jj,jk) = 1.05e4 * zfact * trn(ji,jj,jk,jpgoc)   & 
     170# if defined key_off_degrad 
     171                  &               * facvol(ji,jj,jk)                            & 
     172# endif       
     173                  &               * trn(ji,jj,jk,jpdoc) 
     174 
     175            END DO 
     176         END DO 
     177      END DO 
     178 
     179# if defined key_trc_dia3d 
     180      zrfact2 = 1.e3 * rfact2r 
     181      trc2d(:,:, 5) = zsinking (:,:,iksed+1) * zrfact2 
     182      trc2d(:,:, 6) = zsinking2(:,:,iksed+1) * zrfact2 
     183      trc2d(:,:, 7) = zsinkfer (:,:,iksed+1) * zrfact2 
     184      trc2d(:,:, 8) = zsinkfer2(:,:,iksed+1) * zrfact2 
     185      trc2d(:,:, 9) = zsinksil (:,:,iksed+1) * zrfact2 
     186      trc2d(:,:,10) = zsinkcal (:,:,iksed+1) * zrfact2 
     187# endif 
     188      ! 
     189   END SUBROUTINE p4z_sink 
    42190 
    43191#else 
    44  
    45 # include "p4zsink.std.h" 
    46  
    47 #endif 
    48  
    49 #endif 
    50       RETURN 
    51       END 
     192   !!====================================================================== 
     193   !!  Dummy module :                                   No PISCES bio-model 
     194   !!====================================================================== 
     195CONTAINS 
     196   SUBROUTINE p4z_sink                    ! Empty routine 
     197   END SUBROUTINE p4z_sink 
     198#endif  
     199 
     200   !!====================================================================== 
     201END MODULE  p4zsink 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zsink2.F90

    r774 r775  
     1MODULE p4zsink2 
     2   !!====================================================================== 
     3   !!                         ***  MODULE p4zsink2  *** 
     4   !! TOP :   PISCES Compute vertical flux of particulate matter due to gravitational sinking 
     5   !!====================================================================== 
     6   !! History :   1.0  !  2004     (O. Aumont) Original code 
     7   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     8   !!---------------------------------------------------------------------- 
     9#if defined key_pisces 
     10   !!---------------------------------------------------------------------- 
     11   !!   'key_pisces'                                       PISCES bio-model 
     12   !!---------------------------------------------------------------------- 
     13   !!   p4z_sink2       :  Compute vertical flux of particulate matter due to gravitational sinking 
     14   !!---------------------------------------------------------------------- 
     15   USE oce_trc         ! 
     16   USE trp_trc 
     17   USE sms 
    118 
    2 CCC $Header$  
    3 CCC  TOP 1.0 , LOCEAN-IPSL (2005)  
    4 C This software is governed by CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5 C --------------------------------------------------------------------------- 
    6       SUBROUTINE p4zsink2(wstmp,sinktemp,jn) 
    7 CDIR$ LIST 
    8 #if defined key_top && defined key_pisces 
    9 !!! 
    10 !!!       p4zsink2 : PISCES model 
    11 !!!       *********************** 
    12 !!! 
    13 !! 
    14 !!  PURPOSE : 
    15 !!  --------- 
    16 !!     Compute the sedimentation terms for the various sinking 
    17 !!     particles. The scheme used to compute the trends is based 
    18 !!     on MUSCL.  
    19 !! 
    20 !!   METHOD : 
    21 !!   ------- 
    22 !!      this ROUTINE compute not exactly the advection but the 
    23 !!      transport term, i.e.  div(u*tra). 
    24 !! 
    25 !! 
    26 !!   REFERENCES :                 
    27 !!   ----------                   
    28 !! 
    29 !!   References : 
    30 !!      Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation 
    31 !!      IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 
    32 !! 
    33 !! 
    34 !!   MODIFICATIONS: 
    35 !!   -------------- 
    36 !!       original :  06-00 (A.Estublier) 
    37 !!       modifications : 2004 (O. Aumont) 
    38 !!        
    39 !!---------------------------------------------------------------------- 
    40 CC ---------------------------------------------------------------- 
    41 CC parameters and commons 
    42 CC ====================== 
    43 CDIR$ NOLIST 
    44       USE oce_trc 
    45       USE trp_trc 
    46       USE sms 
    47       IMPLICIT NONE 
    48 #include "domzgr_substitute.h90" 
    49 CDIR$ LIST 
    50 CC----------------------------------------------------------------- 
    51 CC local declarations 
    52 CC ================== 
    53 C 
    54       INTEGER ji,jj,jk,jn 
    55       REAL ztraz(jpi,jpj,jpk),zakz(jpi,jpj,jpk) 
    56       REAL zkz(jpi,jpj,jpk) 
    57       REAL zigma,zew,zstep,zign 
    58       REAL wstmp(jpi,jpj,jpk),sinktemp(jpi,jpj,jpk) 
    59       REAL wstmp2(jpi,jpj,jpk) 
     19   IMPLICIT NONE 
     20   PRIVATE 
    6021 
    61 !!!--------------------------------------------------------------------- 
    62 !!!  OPA8, LODYC (01/00) 
    63 !!!--------------------------------------------------------------------- 
    64 ! 1. Initialization 
    65 ! -------------- 
     22   PUBLIC   p4z_sink2    ! called in p4zbio.F90 
    6623 
    67         zstep  = rfact2 
     24   !!* Substitution 
     25#  include "domzgr_substitute.h90" 
     26   !!---------------------------------------------------------------------- 
     27   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     28   !! $Header:$  
     29   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     30   !!---------------------------------------------------------------------- 
    6831 
    69         ztraz  = 0 
    70         zkz    = 0 
    71         zakz   = 0. 
     32CONTAINS 
    7233 
    73         do jk=1,jpk-1 
     34   SUBROUTINE p4z_sink2( wstmp, sinktemp, jn ) 
     35      !!--------------------------------------------------------------------- 
     36      !!                     ***  ROUTINE p4z_sink2  *** 
     37      !! 
     38      !! ** Purpose :   Compute the sedimentation terms for the various sinking 
     39      !!     particles. The scheme used to compute the trends is based 
     40      !!     on MUSCL. 
     41      !! 
     42      !! ** Method  : - this ROUTINE compute not exactly the advection but the 
     43      !!      transport term, i.e.  div(u*tra). 
     44      !!--------------------------------------------------------------------- 
     45      INTEGER , INTENT(in   )                         ::   jn         ! tracer index index       
     46      REAL(wp), INTENT(in   ), DIMENSION(jpi,jpj,jpk) ::   wstmp      ! ??? 
     47      REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   sinktemp   ! ??? 
     48      !! 
     49      INTEGER  ::   ji, jj, jk 
     50      REAL(wp) ::   zigma,zew,zstep,zign 
     51      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztraz, zakz 
     52      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zkz  , wstmp2 
     53      !!--------------------------------------------------------------------- 
     54 
     55      zstep  = rfact2 
     56 
     57      ztraz(:,:,:) = 0.e0 
     58      zkz  (:,:,:) = 0.e0 
     59      zakz (:,:,:) = 0.e0 
     60 
     61      DO jk = 1, jpkm1 
     62# if defined key_off_degrad 
     63         wstmp2(:,:,jk+1)=-wstmp(:,:,jk)/rjjss*tmask(:,:,jk+1)*facvol(:,:,jk) 
     64# else 
    7465         wstmp2(:,:,jk+1)=-wstmp(:,:,jk)/rjjss*tmask(:,:,jk+1) 
    75 #    if defined key_off_degrad 
    76      &      *facvol(:,:,jk) 
    77 #    endif 
    78         end do 
     66 
     67# endif 
     68      END DO 
    7969  
    80         wstmp2(:,:,1)=0. 
     70      wstmp2(:,:,1) = 0.e0 
    8171! 
    82 ! 3. Vertical advective flux 
     72! Vertical advective flux 
    8373!------------------------------- 
    8474! ... first guess of the slopes 
    8575!   ... interior values 
    86 ! 
    87         DO jk=2,jpkm1 
    88               ztraz(:,:,jk) = (trn(:,:,jk-1,jn) - trn(:,:,jk,jn)) 
    89      $                          *tmask(:,:,jk) 
    90         ENDDO 
     76      DO jk = 2, jpkm1 
     77         ztraz(:,:,jk) = (trn(:,:,jk-1,jn) - trn(:,:,jk,jn)) *tmask(:,:,jk) 
     78      END DO 
    9179! 
    9280! slopes 
    93 ! 
    94         DO jk=2,jpkm1 
    95           DO jj = 1,jpj 
     81      DO jk=2,jpkm1 
     82         DO jj = 1,jpj 
    9683            DO ji = 1, jpi 
    97             zign = 0.5*(sign(1.,ztraz(ji,jj,jk)*ztraz(ji,jj,jk+1))+1) 
    98             zakz(ji,jj,jk) = 0.5*(ztraz(ji,jj,jk) 
    99      $                          +ztraz(ji,jj,jk+1))*zign 
    100             ENDDO 
    101           ENDDO 
    102         ENDDO         
     84               zign = 0.5*(sign(1.,ztraz(ji,jj,jk)*ztraz(ji,jj,jk+1))+1) 
     85               zakz(ji,jj,jk) = 0.5*(ztraz(ji,jj,jk) + ztraz(ji,jj,jk+1) ) * zign 
     86            END DO 
     87          END DO 
     88        END DO         
    10389! 
    10490! Slopes limitation 
    105 ! 
    106         DO jk=2,jpkm1 
    107           DO jj = 1,jpj 
    108             DO ji = 1,jpi 
    109               zakz(ji,jj,jk) = sign(1.,zakz(ji,jj,jk)) *  
    110      $                        min(abs(zakz(ji,jj,jk)), 
    111      $                        2.*abs(ztraz(ji,jj,jk+1)), 
    112      $                        2.*abs(ztraz(ji,jj,jk))) 
    113             ENDDO 
    114           ENDDO 
    115         ENDDO         
     91      DO jk = 2, jpkm1 
     92         DO jj = 1, jpj 
     93            DO ji = 1, jpi 
     94               zakz(ji,jj,jk) = sign(1.,zakz(ji,jj,jk)) *        & 
     95                  &             min(abs(zakz(ji,jj,jk)),         & 
     96                  &             2.*abs(ztraz(ji,jj,jk+1)),       & 
     97                  &             2.*abs(ztraz(ji,jj,jk))) 
     98            END DO 
     99         END DO 
     100      END DO         
    116101 
    117102! vertical advective flux 
    118         DO jk=1,jpkm1 
    119           DO jj = 1,jpj       
     103      DO jk = 1, jpkm1 
     104         DO jj = 1, jpj       
    120105            DO ji = 1, jpi     
    121               zigma = wstmp2(ji,jj,jk+1)*zstep/fse3w(ji,jj,jk+1) 
    122               zew   = wstmp2(ji,jj,jk+1) 
    123               sinktemp(ji,jj,jk+1) = -zew*(trn(ji,jj,jk,jn) 
    124      $           -0.5*(1+zigma)*zakz(ji,jj,jk))*zstep 
    125             ENDDO 
    126           ENDDO 
    127         ENDDO  
     106               zigma = wstmp2(ji,jj,jk+1)*zstep/fse3w(ji,jj,jk+1) 
     107               zew   = wstmp2(ji,jj,jk+1) 
     108               sinktemp(ji,jj,jk+1) = -zew*(trn(ji,jj,jk,jn)                & 
     109                  &                 -0.5*(1+zigma)*zakz(ji,jj,jk))*zstep 
     110            END DO 
     111         END DO 
     112      END DO  
    128113! 
    129114! Boundary conditions 
    130 ! 
    131          sinktemp(:,:,1)=0. 
    132          sinktemp(:,:,jpk)=0. 
    133 C 
    134        DO jk=1,jpkm1 
    135           DO jj = 1,jpj 
     115      sinktemp(:,:,1  ) = 0.e0 
     116      sinktemp(:,:,jpk) = 0.e0 
     117 
     118      DO jk=1,jpkm1 
     119         DO jj = 1,jpj 
    136120            DO ji = 1, jpi 
    137 ! 
    138             trn(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    139      &        + (sinktemp(ji,jj,jk)-sinktemp(ji,jj,jk+1)) 
    140      &        /fse3t(ji,jj,jk) 
    141 ! 
    142             ENDDO 
    143           ENDDO 
    144         ENDDO 
    145 ! 
    146         trb(:,:,:,jn)=trn(:,:,:,jn) 
    147 ! 
    148 #endif 
    149 C 
    150       RETURN 
    151       END 
     121               trn(ji,jj,jk,jn) = trn(ji,jj,jk,jn)               & 
     122                  &        + (sinktemp(ji,jj,jk)-sinktemp(ji,jj,jk+1))     & 
     123                  &        /fse3t(ji,jj,jk) 
     124            END DO 
     125         END DO 
     126      END DO 
     127 
     128      trb(:,:,:,jn) = trn(:,:,:,jn) 
     129      ! 
     130   END SUBROUTINE p4z_sink2 
     131 
     132#else 
     133   !!====================================================================== 
     134   !!  Dummy module :                                   No PISCES bio-model 
     135   !!====================================================================== 
     136CONTAINS 
     137   SUBROUTINE p4z_sink2( wstmp, sinktemp, jn )         ! Empty routine 
     138      INTEGER, INTENT( in ) ::   jn 
     139      REAL   , INTENT( in ) ::   wstmp,sinktemp     
     140      WRITE(*,*) 'p4z_sink2: You should not have seen this print! error?', jn, wstmp, sinktemp 
     141   END SUBROUTINE p4z_sink2 
     142#endif  
     143 
     144   !!====================================================================== 
     145END MODULE  p4zsink2 

  • branches/dev_001_GM/NEMO/TOP_SRC/PISCES_SMS/p4zsink_kriest.F90

    r774 r775  
    1 CCCCCC PISCES MODEL: Kriest parameterization 
    2 CDIR$ LIST 
    3 CC---------------------------------------------------------------------- 
    4 CC local declarations 
    5 CC ================== 
    6       INTEGER jksed, ji, jj, jk 
    7       REAL xagg1,xagg2,xagg3,xagg4,xagg5,xaggsi,xaggsh 
    8       REAL znum(jpi,jpj,jpk) 
    9       REAL xnum,xeps,xfm,xgm,xsm 
    10       REAL xdiv,xdiv1,xdiv2,xdiv3,xdiv4,xdiv5 
    11       REAL zval1, zval2, zval3, zval4 
    12       REAL zstep 
     1MODULE p4zsink_kriest 
     2   !!====================================================================== 
     3   !!                   ***  MODULE p4zsink_kriest  *** 
     4   !! TOP :   PISCES Compute vertical flux of particulate matter due to gravitational sinking 
     5   !!         Kriest parameterization 
     6   !!====================================================================== 
     7   !! History :   1.0  !  2004     (O. Aumont) Original code 
     8   !!             2.0  !  2007-12  (C. Ethe, G. Madec)  F90 
     9   !!---------------------------------------------------------------------- 
     10#if defined key_pisces  &&  defined key_kriest 
     11   !!---------------------------------------------------------------------- 
     12   !!   'key_pisces'    and                                PISCES bio-model 
     13   !!   'key_kriest'                                          kriest option 
     14   !!---------------------------------------------------------------------- 
     15   !!   p4z_sink_kriest :  Compute vertical flux of particulate matter due  
     16   !!                      to gravitational sinking (Kriest parameterization) 
     17   !!---------------------------------------------------------------------- 
     18   USE oce_trc         ! 
     19   USE trp_trc 
     20   USE sms 
     21   USE p4zsink2 
     22 
     23   IMPLICIT NONE 
     24   PRIVATE 
     25 
     26   PUBLIC   p4z_sink_kriest    ! called in p4zbio.F90 
     27 
     28   !!* Substitution 
     29#  include "domzgr_substitute.h90" 
     30   !!---------------------------------------------------------------------- 
     31   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)  
     32   !! $Header:$  
     33   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
     34   !!---------------------------------------------------------------------- 
     35 
     36CONTAINS 
     37 
     38   SUBROUTINE p4z_sink_kriest 
     39      !!--------------------------------------------------------------------- 
     40      !!                ***  ROUTINE p4z_sink_kriest  *** 
     41      !! 
     42      !! ** Purpose :   Compute vertical flux of particulate matter due to  
     43      !!              gravitational sinking - Kriest parameterization 
     44      !! 
     45      !! ** Method  : - ??? 
     46      !!--------------------------------------------------------------------- 
     47      INTEGER  ::   ji, jj, jk 
     48      INTEGER  ::   iksed 
     49      REAL(wp) ::   zagg1, zagg2, zagg3, zagg4, zagg5, zaggsi, zaggsh 
     50      REAL(wp) ::   znum , zeps, zfm, zgm, zsm 
     51      REAL(wp) ::   zdiv , zdiv1, zdiv2, zdiv3, zdiv4, zdiv5 
     52      REAL(wp) ::   zval1, zval2, zval3, zval4 
     53      REAL(wp) ::   zstep 
    1354#if defined key_trc_dia3d 
    14       REAL zrfact2 
     55      REAL(wp) ::  zrfact2 
    1556#endif 
    16       REAL sinking(jpi,jpj,jpk),sinking2(jpi,jpj,jpk) 
    17       REAL sinkfer(jpi,jpj,jpk) 
    18       REAL sinkcal(jpi,jpj,jpk),sinksil(jpi,jpj,jpk) 
    19 C 
    20 C 
    21 C    Time step duration for biology 
    22 C    ------------------------------ 
    23 C 
    24        zstep=rfact2/rjjss 
    25         
    26 C 
    27 C 
    28 C     Initialisation of variables used to compute Sinking Speed 
    29 C     --------------------------------------------------------- 
    30 C 
    31        znum(:,:,:) = 0. 
    32        jksed = 10 
     57      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   znum3d 
     58      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   sinking, sinking2 
     59      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   sinkfer 
     60      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   sinkcal, sinksil 
     61      !!--------------------------------------------------------------------- 
     62 
     63       zstep=rfact2/rjjss      ! Time step duration for biology 
     64 
     65 
     66!     Initialisation of variables used to compute Sinking Speed 
     67!     --------------------------------------------------------- 
     68 
     69       znum3d(:,:,:) = 0.e0 
     70       iksed = 10 
    3371       zval1 = 1. + xkr_zeta 
    3472       zval2 = 1. + xkr_zeta + xkr_eta 
    3573       zval3 = 1. + xkr_eta 
    36 C 
    37 C     Computation of the vertical sinking speed : Kriest et Evans, 2000 
    38 C     ----------------------------------------------------------------- 
    39 C     
    40        do jk=1,jpk-1 
    41          do jj=1,jpj 
    42            do ji=1,jpi 
    43              IF (tmask(ji,jj,jk).NE.0) THEN 
    44                  xnum = trn(ji,jj,jk,jppoc) / (trn(ji,jj,jk,jpnum)+rtrn) 
    45      &                     / xkr_massp 
    46 C -------------- To avoid sinking speed over 50 m/day ------- 
    47                  xnum = min( xnumm(jk), xnum ) 
    48                  xnum = max( 1.1, xnum ) 
    49                  znum(ji,jj,jk) = xnum 
    50 C------------------------------------------------------------ 
    51                  xeps = ( zval1 * xnum - 1. )/ ( xnum - 1. ) 
    52                  xfm  = xkr_frac**( 1. - xeps ) 
    53                  xgm  = xkr_frac**( zval1 - xeps ) 
    54                  xdiv = max(1E-4,abs(xeps-zval2))*sign(1.,(xeps-zval2)) 
    55                  xdiv1=(xeps-zval3) 
    56                  wsbio3(ji,jj,jk)= xkr_wsbio_min * ( xeps-zval1 ) / xdiv 
    57      &                           - xkr_wsbio_max * xgm * xkr_eta / xdiv 
    58                  wsbio4(ji,jj,jk)= xkr_wsbio_min * ( xeps-1. ) / xdiv1 
    59      &                           - xkr_wsbio_max * xfm * xkr_eta / xdiv1 
    60                  IF( xnum == 1.1) THEN 
    61                      wsbio3(ji,jj,jk) = wsbio4(ji,jj,jk) 
    62                  ENDIF 
    63              ENDIF 
    64            end do 
    65          end do 
    66        end do 
    67 C 
    68        wscal(:,:,:)=max(wsbio3(:,:,:),50.) 
    69 C 
    70 C 
    71 C   INITIALIZE TO ZERO ALL THE SINKING ARRAYS 
    72 C   ----------------------------------------- 
    73 C 
    74          sinking=0. 
    75          sinking2=0. 
    76          sinkcal=0. 
    77          sinkfer=0. 
    78          sinksil=0. 
    79 C 
    80 C   Compute the sedimentation term using p4zsink2 for all 
    81 C   the sinking particles 
    82 C   ----------------------------------------------------- 
    83 C 
    84          CALL p4zsink2(wsbio3,sinking,jppoc) 
    85          CALL p4zsink2(wsbio4,sinking2,jpnum) 
    86          CALL p4zsink2(wsbio3,sinkfer,jpsfe) 
    87          CALL p4zsink2(wscal,sinksil,jpdsi) 
    88          CALL p4zsink2(wscal,sinkcal,jpcal) 
    89  
    90 C 
    91 C  Exchange between organic matter compartments due to 
    92 C  coagulation/disaggregation 
    93 C  --------------------------------------------------- 
    94 C 
    95          zval1 = 1. + xkr_zeta 
    96          zval2 = 1. + xkr_eta 
    97          zval3 = 3. + xkr_eta 
    98          zval4 = 4. + xkr_eta 
    99  
    100          DO jk = 1,jpkm1 
    101            DO jj = 1,jpj 
    102              DO ji = 1,jpi 
    103                IF (tmask(ji,jj,jk).NE.0.) THEN 
    104 C 
    105                    xnum=trn(ji,jj,jk,jppoc)/(trn(ji,jj,jk,jpnum)+rtrn) 
    106      &                         /xkr_massp 
    107 C -------------- To avoid sinking speed over 50 m/day ------- 
    108                    xnum=min(xnumm(jk),xnum) 
    109                    xnum=max(1.1,xnum) 
    110 C------------------------------------------------------------ 
    111                    xeps =(zval1*xnum-1.)/(xnum-1.) 
    112                    xdiv =max(1E-4,abs(xeps-zval3))*sign(1.,(xeps-zval3)) 
    113                    xdiv1=max(1E-4,abs(xeps-4.))*sign(1.,(xeps-4.)) 
    114                    xdiv2=(xeps-2.) 
    115                    xdiv3=(xeps-3.) 
    116                    xdiv4=(xeps-zval2) 
    117                    xdiv5=(2*xeps-zval4) 
    118                    xfm=xkr_frac**(1.-xeps) 
    119                    xsm=xkr_frac**xkr_eta 
    120 C 
    121 C    Part I : Coagulation dependant on turbulence 
    122 C    ---------------------------------------------- 
    123 C 
    124                    xagg1=(0.163*trn(ji,jj,jk,jpnum)**2 
    125      &           *2.*( (xfm-1.)*(xfm*xkr_mass_max**3-xkr_mass_min**3) 
    126      &           *(xeps-1)/xdiv1 + 3.*(xfm*xkr_mass_max-xkr_mass_min) 
    127      &           *(xfm*xkr_mass_max**2-xkr_mass_min**2) 
    128      &           *(xeps-1.)**2/(xdiv2*xdiv3))) 
     74 
     75!     Computation of the vertical sinking speed : Kriest et Evans, 2000 
     76!     ----------------------------------------------------------------- 
     77     
     78      DO jk = 1, jpkm1 
     79         DO jj = 1, jpj 
     80            DO ji = 1, jpi 
     81               IF( tmask(ji,jj,jk) /= 0.e0 ) THEN 
     82                  znum = trn(ji,jj,jk,jppoc) / ( trn(ji,jj,jk,jpnum) + rtrn ) / xkr_massp 
     83! -------------- To avoid sinking speed over 50 m/day ------- 
     84                  znum  = MIN( xnumm(jk), znum ) 
     85                  znum  = MAX( 1.1      , znum ) 
     86                  znum3d(ji,jj,jk) = znum 
     87!------------------------------------------------------------ 
     88                  zeps  = ( zval1 * znum - 1. )/ ( znum - 1. ) 
     89                  zfm   = xkr_frac**( 1. - zeps ) 
     90                  zgm   = xkr_frac**( zval1 - zeps ) 
     91                  zdiv  = MAX( 1.e-4, ABS( zeps - zval2 ) ) * SIGN( 1., ( zeps - zval2 ) ) 
     92                  zdiv1 = zeps - zval3 
     93!!gmoptimisation possible below 
     94                  wsbio3(ji,jj,jk) = xkr_wsbio_min * ( zeps - zval1 ) / zdiv    & 
     95     &                             - xkr_wsbio_max *   zgm * xkr_eta  / zdiv 
     96                  wsbio4(ji,jj,jk) = xkr_wsbio_min *   ( zeps-1. )    / zdiv1   & 
     97     &                             - xkr_wsbio_max *   zfm * xkr_eta  / zdiv1 
     98                  IF( znum == 1.1)   wsbio3(ji,jj,jk) = wsbio4(ji,jj,jk) 
     99               ENDIF 
     100            END DO 
     101         END DO 
     102      END DO 
     103 
     104      wscal(:,:,:) = MAX( wsbio3(:,:,:), 50. ) 
     105 
     106 
     107!   INITIALIZE TO ZERO ALL THE SINKING ARRAYS 
     108!   ----------------------------------------- 
     109 
     110      sinking (:,:,:) = 0.e0 
     111      sinking2(:,:,:) = 0.e0 
     112      sinkcal (:,:,:) = 0.e0 
     113      sinkfer (:,:,:) = 0.e0 
     114      sinksil (:,:,:) = 0.e0 
     115 
     116!   Compute the sedimentation term using p4zsink2 for all 
     117!   the sinking particles 
     118!   ----------------------------------------------------- 
     119 
     120      CALL p4z_sink2( wsbio3, sinking , jppoc ) 
     121      CALL p4z_sink2( wsbio4, sinking2, jpnum ) 
     122      CALL p4z_sink2( wsbio3, sinkfer , jpsfe ) 
     123      CALL p4z_sink2( wscal , sinksil , jpdsi ) 
     124      CALL p4z_sink2( wscal , sinkcal , jpcal ) 
     125 
     126!  Exchange between organic matter compartments due to 
     127!  coagulation/disaggregation 
     128!  --------------------------------------------------- 
     129 
     130      zval1 = 1. + xkr_zeta 
     131      zval2 = 1. + xkr_eta 
     132      zval3 = 3. + xkr_eta 
     133      zval4 = 4. + xkr_eta 
     134 
     135      DO jk = 1,jpkm1 
     136         DO jj = 1,jpj 
     137            DO ji = 1,jpi 
     138               IF( tmask(ji,jj,jk) /= 0.e0 ) THEN 
     139 
     140                  znum = trn(ji,jj,jk,jppoc)/(trn(ji,jj,jk,jpnum)+rtrn) / xkr_massp 
     141! -------------- To avoid sinking speed over 50 m/day ------- 
     142                  znum  = min(xnumm(jk),znum) 
     143                  znum  = MAX( 1.1,znum) 
     144!------------------------------------------------------------ 
     145                  zeps  = ( zval1 * znum - 1.) / ( znum - 1.) 
     146                  zdiv  = MAX( 1.e-4, ABS( zeps - zval3) ) * SIGN( 1., zeps - zval3 ) 
     147                  zdiv1 = MAX( 1.e-4, ABS( zeps - 4.   ) ) * SIGN( 1., zeps - 4.    ) 
     148                  zdiv2 = zeps - 2. 
     149                  zdiv3 = zeps - 3. 
     150                  zdiv4 = zeps - zval2 
     151                  zdiv5 = 2.* zeps - zval4 
     152                  zfm   = xkr_frac**( 1.- zeps ) 
     153                  zsm   = xkr_frac**xkr_eta 
     154 
     155!    Part I : Coagulation dependant on turbulence 
     156!    ---------------------------------------------- 
     157 
     158                  zagg1 = ( 0.163 * trn(ji,jj,jk,jpnum)**2               & 
     159                     &            * 2.*( (zfm-1.)*(zfm*xkr_mass_max**3-xkr_mass_min**3)    & 
     160                     &            * (zeps-1)/zdiv1 + 3.*(zfm*xkr_mass_max-xkr_mass_min)    & 
     161                     &            * (zfm*xkr_mass_max**2-xkr_mass_min**2)                  & 
     162                     &            * (zeps-1.)**2/(zdiv2*zdiv3))            & 
     163# if defined key_off_degrad 
     164                     &                 *facvol(ji,jj,jk)       & 
     165# endif 
     166                     &    ) 
     167 
     168                  zagg2 = (  2*0.163*trn(ji,jj,jk,jpnum)**2*zfm*                       & 
     169                     &                   ((xkr_mass_max**3+3.*(xkr_mass_max**2          & 
     170                     &                    *xkr_mass_min*(zeps-1.)/zdiv2                 & 
     171                     &                    +xkr_mass_max*xkr_mass_min**2*(zeps-1.)/zdiv3)    & 
     172                     &                    +xkr_mass_min**3*(zeps-1)/zdiv1)                  & 
     173                     &                    -zfm*xkr_mass_max**3*(1.+3.*((zeps-1.)/           & 
     174                     &                    (zeps-2.)+(zeps-1.)/zdiv3)+(zeps-1.)/zdiv1))      & 
    129175#    if defined key_off_degrad 
    130      &                 *facvol(ji,jj,jk) 
     176                     &                 *facvol(ji,jj,jk)             & 
    131177#    endif 
    132  
    133 C 
    134                    xagg2=(2*0.163*trn(ji,jj,jk,jpnum)**2*xfm* 
    135      &                   ((xkr_mass_max**3+3.*(xkr_mass_max**2 
    136      &                    *xkr_mass_min*(xeps-1.)/xdiv2 
    137      &                    +xkr_mass_max*xkr_mass_min**2*(xeps-1.)/xdiv3) 
    138      &                    +xkr_mass_min**3*(xeps-1)/xdiv1) 
    139      &                    -xfm*xkr_mass_max**3*(1.+3.*((xeps-1.)/ 
    140      &                    (xeps-2.)+(xeps-1.)/xdiv3)+(xeps-1.)/xdiv1))) 
     178                     &    ) 
     179 
     180                  zagg3 = (  0.163*trn(ji,jj,jk,jpnum)**2*zfm**2*8. * xkr_mass_max**3   & 
    141181#    if defined key_off_degrad 
    142      &                 *facvol(ji,jj,jk) 
     182                     &                 *facvol(ji,jj,jk)             & 
    143183#    endif 
    144 C 
    145                    xagg3=(0.163*trn(ji,jj,jk,jpnum)**2*xfm**2*8. 
    146      &                 *xkr_mass_max**3) 
    147 #    if defined key_off_degrad 
    148      &                 *facvol(ji,jj,jk) 
     184                     &    ) 
     185 
     186                  zaggsh = ( zagg1 + zagg2 + zagg3 ) * rfact2 * zdiss(ji,jj,jk) / 1000. 
     187 
     188!    Aggregation of small into large particles 
     189!    Part II : Differential settling 
     190!    ---------------------------------------------- 
     191 
     192                  zagg4 = (  2.*3.141*0.125*trn(ji,jj,jk,jpnum)**2*                       & 
     193                     &                 xkr_wsbio_min*(zeps-1.)**2                         & 
     194                     &                 *(xkr_mass_min**2*((1.-zsm*zfm)/(zdiv3*zdiv4)      & 
     195                     &                 -(1.-zfm)/(zdiv*(zeps-1.)))-                       & 
     196                     &                 ((zfm*zfm*xkr_mass_max**2*zsm-xkr_mass_min**2)     & 
     197                     &                 *xkr_eta)/(zdiv*zdiv3*zdiv5) )                     & 
     198# if defined key_off_degrad 
     199                     &                 *facvol(ji,jj,jk)        & 
     200# endif 
     201                     &    ) 
     202 
     203                  zagg5 = (  2.*3.141*0.125*trn(ji,jj,jk,jpnum)**2                         & 
     204                     &                 *(zeps-1.)*zfm*xkr_wsbio_min                        & 
     205                     &                 *(zsm*(xkr_mass_min**2-zfm*xkr_mass_max**2)         & 
     206                     &                 /zdiv3-(xkr_mass_min**2-zfm*zsm*xkr_mass_max**2)    & 
     207                     &                 /zdiv)                   & 
     208# if defined key_off_degrad 
     209                     &                 *facvol(ji,jj,jk)        & 
     210# endif 
     211                     &    ) 
     212 
     213                  zaggsi = ( zagg4 + zagg5 ) * zstep / 10. 
     214 
     215                  xagg(ji,jj,jk) = 0.5 * xkr_stick * ( zaggsh + zaggsi ) 
     216 
     217!     Aggregation of DOC to small particles 
     218!     -------------------------------------- 
     219 
     220                  xaggdoc(ji,jj,jk) = (     0.4 * trn(ji,jj,jk,jpdoc)               & 
     221                     &                 + 1018.  * trn(ji,jj,jk,jppoc)  ) * zstep    & 
     222# if defined key_off_degrad 
     223                     &              * facvol(ji,jj,jk)                              & 
     224# endif 
     225                     &              * zdiss(ji,jj,jk) * trn(ji,jj,jk,jpdoc) 
     226 
     227               ENDIF 
     228            END DO 
     229         END DO 
     230      END DO 
     231 
     232#    if defined key_trc_dia3d 
     233      zrfact2 = 1.e3 * rfact2r 
     234      trc2d(:,:, 5)   = sinking (:,:,iksed+1) * zrfact2 
     235      trc2d(:,:, 6)   = sinking2(:,:,iksed+1) * zrfact2 
     236      trc2d(:,:, 7)   = sinkfer (:,:,iksed+1) * zrfact2 
     237      trc2d(:,:, 9)   = sinksil (:,:,iksed+1) * zrfact2 
     238      trc2d(:,:,10)   = sinkcal (:,:,iksed+1) * zrfact2 
     239      trc3d(:,:,:,12) = sinking (:,:,:)       * zrfact2 
     240      trc3d(:,:,:,13) = sinking2(:,:,:)       * zrfact2 
     241      trc3d(:,:,:,14) = sinksil (:,:,:)       * zrfact2 
     242      trc3d(:,:,:,15) = sinkcal (:,:,:)       * zrfact2 
     243      trc3d(:,:,:,16) = znum3d  (:,:,:) 
     244      trc3d(:,:,:,17) = wsbio3  (:,:,:) 
     245      trc3d(:,:,:,18) = wsbio4  (:,:,:) 
    149246#    endif 
    150 C 
    151                    xaggsh=(xagg1+xagg2+xagg3)*rfact2*zdiss(ji,jj,jk) 
    152      &                 /1000. 
    153 C 
    154 C    Aggregation of small into large particles 
    155 C    Part II : Differential settling 
    156 C    ---------------------------------------------- 
    157 C 
    158                    xagg4=(2.*3.141*0.125*trn(ji,jj,jk,jpnum)**2* 
    159      &                 xkr_wsbio_min*(xeps-1.)**2 
    160      &                 *(xkr_mass_min**2*((1.-xsm*xfm)/(xdiv3*xdiv4) 
    161      &                 -(1.-xfm)/(xdiv*(xeps-1.)))- 
    162      &                 ((xfm*xfm*xkr_mass_max**2*xsm-xkr_mass_min**2) 
    163      &                 *xkr_eta)/(xdiv*xdiv3*xdiv5))) 
    164 #    if defined key_off_degrad 
    165      &                 *facvol(ji,jj,jk) 
    166 #    endif 
    167 C 
    168                    xagg5=(2.*3.141*0.125*trn(ji,jj,jk,jpnum)**2 
    169      &                 *(xeps-1.)*xfm*xkr_wsbio_min 
    170      &                 *(xsm*(xkr_mass_min**2-xfm*xkr_mass_max**2) 
    171      &                 /xdiv3-(xkr_mass_min**2-xfm*xsm*xkr_mass_max**2) 
    172      &                 /xdiv)) 
    173 #    if defined key_off_degrad 
    174      &                 *facvol(ji,jj,jk) 
    175 #    endif 
    176 C 
    177                    xaggsi=(xagg4+xagg5)*zstep/10. 
    178 C 
    179                    xagg(ji,jj,jk)=0.5 * xkr_stick*(xaggsh+xaggsi) 
    180 C 
    181 C     Aggregation of DOC to small particles 
    182 C     -------------------------------------- 
    183 C 
    184                    xaggdoc(ji,jj,jk)=(0.4*trn(ji,jj,jk,jpdoc) 
    185      &                 +1018.*trn(ji,jj,jk,jppoc))*zstep 
    186      &                 *zdiss(ji,jj,jk)*trn(ji,jj,jk,jpdoc) 
    187 #    if defined key_off_degrad 
    188      &                 *facvol(ji,jj,jk) 
    189 #    endif 
    190 C 
    191  
    192                ENDIF 
    193              END DO 
    194            END DO 
    195          END DO 
    196 C 
    197 #    if defined key_trc_dia3d 
    198          zrfact2 = 1.e3*rfact2r 
    199          trc2d(:,:,5) = sinking(:,:,jksed+1)*zrfact2 
    200          trc2d(:,:,6) = sinking2(:,:,jksed+1)*zrfact2 
    201          trc2d(:,:,7) = sinkfer(:,:,jksed+1)*zrfact2 
    202          trc2d(:,:,9) = sinksil(:,:,jksed+1)*zrfact2 
    203          trc2d(:,:,10) = sinkcal(:,:,jksed+1)*zrfact2 
    204          trc3d(:,:,:,12) = sinking(:,:,:)*zrfact2 
    205          trc3d(:,:,:,13) = sinking2(:,:,:)*zrfact2 
    206          trc3d(:,:,:,14) = sinksil(:,:,:)*zrfact2 
    207          trc3d(:,:,:,15) = sinkcal(:,:,:)*zrfact2 
    208          trc3d(:,:,:,16) = znum(:,:,:) 
    209          trc3d(:,:,:,17) = wsbio3(:,:,:) 
    210          trc3d(:,:,:,18) = wsbio4(:,:,:) 
    211 #    endif 
     247      ! 
     248   END SUBROUTINE p4z_sink_kriest 
     249 
     250#else 
     251   !!====================================================================== 
     252   !!  Dummy module :                                   No PISCES bio-model 
     253   !!====================================================================== 
     254CONTAINS 
     255   SUBROUTINE p4z_sink_kriest                    ! Empty routine 
     256   END SUBROUTINE p4z_sink_kriest 
     257#endif  
     258 
     259   !!====================================================================== 
     260END MODULE  p4zsink_kriest 
Note: See TracChangeset for help on using the changeset viewer.