Ignore:
Timestamp:
Jul 23, 2024, 5:57:06 PM (14 months ago)
Author:
abarral
Message:

Replace 1DUTILS.h by module lmdz_1dutils.f90
Replace 1DConv.h by module lmdz_old_1dconv.f90 (it's only used by old_* files)
Convert *.F in DUST to *.f90

Location:
LMDZ6/branches/Amaury_dev/libf/phylmd/Dust
Files:
21 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/aeropt_spl.f90

    r5103 r5104  
    1       SUBROUTINE aeropt_spl(zdz, tr_seri, RHcl,
    2      .              id_prec, id_fine, id_coss, id_codu, id_scdu,
    3      .              ok_chimeredust,
    4      .                      ztaue550,ztaue670,ztaue865,
    5      .                      taue550_tr2,taue670_tr2,taue865_tr2,
    6      .                      taue550_ss,taue670_ss,taue865_ss,
    7      .                      taue550_dust,taue670_dust,taue865_dust,
    8      .             taue550_dustsco,taue670_dustsco,taue865_dustsco)
    9 c
    10       USE dimphy
    11       USE infotrac
    12       IMPLICIT none
    13 c
    14       INCLUDE "chem.h"
    15       INCLUDE "dimensions.h"
    16 cINCLUDE "dimphy.h"
    17       INCLUDE "YOMCST.h"
    18 c
    19 c Arguments:
    20 c
    21 c======================== INPUT ==================================     
    22       REAL zdz(klon,klev)
    23       REAL tr_seri(klon,klev,nbtr) ! masse of tracer
    24       REAL RHcl(klon,klev)     ! humidite relativen ciel clair
    25       INTEGER  id_prec, id_fine, id_coss, id_codu, id_scdu
    26       LOGICAL ok_chimeredust
    27 c============================== OUTPUT =================================
    28       REAL ztaue550(klon) ! epaisseur optique aerosol 550 nm
    29       REAL ztaue670(klon) ! epaisseur optique aerosol 670 nm
    30       REAL ztaue865(klon) ! epaisseur optique aerosol 865 nm
    31       REAL taue550_tr2(klon) ! epaisseur optique aerosol 550 nm, diagnostic
    32       REAL taue670_tr2(klon) ! epaisseur optique aerosol 670 nm, diagnostic
    33       REAL taue865_tr2(klon) ! epaisseur optique aerosol 865 nm, diagnostic
    34       REAL taue550_ss(klon) ! epaisseur optique aerosol 550 nm, diagnostic
    35       REAL taue670_ss(klon) ! epaisseur optique aerosol 670 nm, diagnostic
    36       REAL taue865_ss(klon) ! epaisseur optique aerosol 865 nm, diagnostic
    37       REAL taue550_dust(klon) ! epaisseur optique aerosol 550 nm, diagnostic
    38       REAL taue670_dust(klon) ! epaisseur optique aerosol 670 nm, diagnostic
    39       REAL taue865_dust(klon) ! epaisseur optique aerosol 865 nm, diagnostic
    40       REAL taue550_dustsco(klon) ! epaisseur optique aerosol 550 nm, diagnostic
    41       REAL taue670_dustsco(klon) ! epaisseur optique aerosol 670 nm, diagnostic
    42       REAL taue865_dustsco(klon) ! epaisseur optique aerosol 865 nm, diagnostic
    43 c===================== LOCAL VARIABLES ===========================     
    44       INTEGER nb_lambda,nbre_RH
    45       PARAMETER (nb_lambda=3,nbre_RH=12)
    46       INTEGER i, k, RH_num
    47       REAL rh, RH_MAX, DELTA, RH_tab(nbre_RH)
    48       PARAMETER (RH_MAX=95.)
    49       INTEGER rh_int
    50       PARAMETER (rh_int=12)
    51       REAL auxreal
    52 c      REAL ss_a(nb_lambda,int,nbtr-1)
    53 c      DATA ss_a/72*1./
    54       REAL ss_dust(nb_lambda), ss_acc550(rh_int), alpha_acc
    55       REAL ss_dustsco(nb_lambda)
    56       REAL ss_acc670(rh_int), ss_acc865(rh_int)
    57       REAL ss_ssalt550(rh_int)
    58       REAL ss_ssalt670(rh_int), ss_ssalt865(rh_int)
    59       REAL burden_ss(klon)
    60       DATA ss_acc550 /3.135,3.135,3.135, 3.135, 4.260, 4.807,
    61      .                5.546,6.651,8.641,10.335,13.534,22.979/
    62       DATA ss_acc670 /2.220,2.220,2.220, 2.220, 3.048, 3.460,
    63      .                4.023,4.873,6.426, 7.761,10.322,18.079/
    64       DATA ss_acc865 /1.329,1.329,1.329, 1.329, 1.855, 2.124,
    65      .                2.494,3.060,4.114, 5.033, 6.831,12.457/ 
    66 !old4tracers      DATA ss_dust/0.564, 0.614, 0.700/ !for bin 0.5-10um
    67 !      DATA ss_dust/0.553117, 0.610185, 0.7053460 / !for bin 0.5-3um radius
    68 !      DATA ss_dustsco/0.1014, 0.102156, 0.1035538 / !for bin 3-15um radius
    69 !20140902      DATA ss_dust/0.5345737, 0.5878828, 0.6772957/ !for bin 0.5-3um radius
    70 !20140902      DATA ss_dustsco/0.1009634, 0.1018700, 0.1031178/ !for bin 3-15um radius
    71 !3days      DATA ss_dust/0.4564216, 0.4906738, 0.5476248/ !for bin 0.5-3um radius
    72 !3days      DATA ss_dustsco/0.1015022, 0.1024051, 0.1036622/ !for bin 3-15um radius
    73 !JE20140911      DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
    74 !JE20140911      DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
    75 !JE20140915      DATA ss_dust/0.3188754,0.3430106,0.3829019/ !for bin 0.5-5um radius
    76 !JE20140915      DATA ss_dustsco/8.0582686E-02,8.1255026E-02,8.1861295E-02/ !for bin 5-15um radius
    77 
    78 !      DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
    79 !      DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
    80 
    81 
    82       DATA ss_ssalt550/0.182,0.182,0.182,0.182,0.366,0.430,
    83      .                 0.484,0.551,0.648,0.724,0.847,1.218/ !for bin 0.5-20 um, fit_v2
    84       DATA ss_ssalt670/0.193,0.193,0.193,0.193,0.377,0.431,
    85      .                 0.496,0.587,0.693,0.784,0.925,1.257/ !for bin 0.5-20 um
    86       DATA ss_ssalt865/0.188,0.188,0.188,0.188,0.384,0.443,
    87      .                 0.502,0.580,0.699,0.799,0.979,1.404/ !for bin 0.5-20 um
    88 
    89       DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
    90 c
    91       IF (ok_chimeredust) THEN
    92 !JE20150212<< : changes in ustar in dustmod changes emission distribution
    93 !      ss_dust=(/0.5167768,0.5684330,0.6531643/)
    94 !      ss_dustsco=(/0.1003391,0.1012288,0.1024651/)
    95 ! JE20150618: Change in dustmodule, div3 is now =6: change distributions
    96 ! div3=3      ss_dust   =(/0.4670522 , 0.5077308 , 0.5745184/)
    97 ! div3=3      ss_dustsco=(/0.099858  , 0.1007395 , 0.1019673/)
    98       ss_dust   =(/0.4851232 , 0.5292494 , 0.5935509/)
    99       ss_dustsco=(/0.1001981 , 0.1011043 , 0.1023113/)
    100 
    101 !JE20150212>>
    102 
    103       ELSE
    104       ss_dust=(/0.564, 0.614, 0.700/)
    105       ss_dustsco=(/0.,0.,0./)
    106       ENDIF
    107 
    108       DO i=1, klon
    109         ztaue550(i)=0.0
    110         ztaue670(i)=0.0
    111         ztaue865(i)=0.0
    112         taue550_tr2(i)=0.0
    113         taue670_tr2(i)=0.0
    114         taue865_tr2(i)=0.0
    115         taue550_ss(i)=0.0
    116         taue670_ss(i)=0.0
    117         taue865_ss(i)=0.0
    118         taue550_dust(i)=0.0
    119         taue670_dust(i)=0.0
    120         taue865_dust(i)=0.0
    121         taue550_dustsco(i)=0.0
    122         taue670_dustsco(i)=0.0
    123         taue865_dustsco(i)=0.0
    124         burden_ss(i)=0.0
    125       ENDDO
    126 
    127       DO k=1, klev
    128       DO i=1, klon
    129 c     
    130       rh=MIN(RHcl(i,k)*100.,RH_MAX)
    131       RH_num = INT( rh/10. + 1.)
    132       IF (rh>85.) RH_num=10
    133       IF (rh>90.) RH_num=11
    134 c      IF (rh.gt.40.) THEN
    135 c          RH_num=5   ! Added by NHL temporarily
    136 c          print *,'TEMPORARY CASE'
    137 c      ENDIF
    138       DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
    139 
    140 
    141 c*******************************************************************
    142 c                       AOD at 550 NM
    143 c*******************************************************************
    144         alpha_acc=ss_acc550(RH_num) + DELTA*(ss_acc550(RH_num+1)-
    145      .            ss_acc550(RH_num))              !--m2/g
    146 cnhl_test TOTAL AOD
    147        auxreal=0.
    148       IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
    149       IF(id_coss>0) auxreal=auxreal+ss_ssalt550(RH_num)*
    150      .                       tr_seri(i,k,id_coss)
    151       IF(id_codu>0) auxreal=auxreal+ss_dust(1)*tr_seri(i,k,id_codu)
    152       IF(id_scdu>0) auxreal=auxreal+ss_dustsco(1)*tr_seri(i,k,id_scdu)
    153       ztaue550(i)=ztaue550(i)+auxreal*zdz(i,k)*1.e6
    154    
    155 !JE20150128        ztaue550(i)=ztaue550(i)+(alpha_acc*tr_seri(i,k,id_fine)+
    156 !     .                 ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)+
    157 !     .                 ss_dust(1)*tr_seri(i,k,id_codu)+
    158 !     .              ss_dustsco(1)*tr_seri(i,k,id_scdu)  )*zdz(i,k)*1.e6
    159 
    160 cnhl_test TOTAL AOD IS NOW AOD COARSE MODE ONLY
    161 cnhl_test        ztaue550(i)=ztaue550(i)+(                     
    162 cnhl_test     .                 ss_ssalt550(RH_num)*tr_seri(i,k,3)+
    163 cnhl_test     .                 ss_dust(1)*tr_seri(i,k,4))*zdz(i,k)*1.e6
    164 
    165         IF(id_fine>0) taue550_tr2(i)=taue550_tr2(i)
    166      .               + alpha_acc*tr_seri(i,k,id_fine)*zdz(i,k)*1.e6
    167         IF(id_coss>0) taue550_ss(i)=taue550_ss(i)+
    168      .                ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)*
    169      .                zdz(i,k)*1.e6
    170         IF(id_codu>0) taue550_dust(i)=taue550_dust(i)+
    171      .                ss_dust(1)*tr_seri(i,k,id_codu)*
    172      .                zdz(i,k)*1.e6
    173         IF(id_scdu>0) taue550_dustsco(i)=taue550_dustsco(i)+
    174      .                ss_dustsco(1)*tr_seri(i,k,id_scdu)*
    175      .                zdz(i,k)*1.e6
    176 !        print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
    177 !     .                                          MAXVAL(taue550_ss)
    178 
    179 c*******************************************************************
    180 c                       AOD at 670 NM
    181 c*******************************************************************
    182         alpha_acc=ss_acc670(RH_num) + DELTA*(ss_acc670(RH_num+1)-
    183      .            ss_acc670(RH_num))              !--m2/g
    184       auxreal=0.
    185       IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
    186       IF(id_coss>0) auxreal=auxreal+ss_ssalt670(RH_num)
    187      .                      *tr_seri(i,k,id_coss)
    188       IF(id_codu>0) auxreal=auxreal+ss_dust(2)*tr_seri(i,k,id_codu)
    189       IF(id_scdu>0) auxreal=auxreal+ss_dustsco(2)*tr_seri(i,k,id_scdu)
    190       ztaue670(i)=ztaue670(i)+auxreal*zdz(i,k)*1.e6
    191 
    192 !JE20150128        ztaue670(i)=ztaue670(i)+(alpha_acc*tr_seri(i,k,id_fine)+
    193 !     .                 ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)+
    194 !     .                 ss_dust(2)*tr_seri(i,k,id_codu)+
    195 !     .               ss_dustsco(2)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
    196 
    197       IF(id_fine>0)  taue670_tr2(i)=taue670_tr2(i)+
    198      .                alpha_acc*tr_seri(i,k,id_fine)*
    199      .                 zdz(i,k)*1.e6
    200       IF(id_coss>0)  taue670_ss(i)=taue670_ss(i)+
    201      .                ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)*
    202      .                zdz(i,k)*1.e6
    203       IF(id_codu>0)  taue670_dust(i)=taue670_dust(i)
    204      .                +ss_dust(2)*tr_seri(i,k,id_codu)*
    205      .                zdz(i,k)*1.e6
    206       IF(id_scdu>0)  taue670_dustsco(i)=taue670_dustsco(i)+
    207      .                ss_dustsco(2)*tr_seri(i,k,id_scdu)*
    208      .                zdz(i,k)*1.e6
    209 
    210 c*******************************************************************
    211 c                       AOD at 865 NM
    212 c*******************************************************************
    213         alpha_acc=ss_acc865(RH_num) + DELTA*(ss_acc865(RH_num+1)-
    214      .            ss_acc865(RH_num))              !--m2/g
    215         auxreal=0.
    216       IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
    217       IF(id_coss>0) auxreal=auxreal
    218      .                     +ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)
    219       IF(id_codu>0) auxreal=auxreal+ss_dust(3)*tr_seri(i,k,id_codu)
    220       IF(id_scdu>0) auxreal=auxreal+ss_dustsco(3)*tr_seri(i,k,id_scdu)
    221         ztaue865(i)=ztaue865(i)+auxreal*zdz(i,k)*1.e6
    222 !JE20150128        ztaue865(i)=ztaue865(i)+(alpha_acc*tr_seri(i,k,id_fine)+
    223 !     .                 ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)+
    224 !     .                 ss_dust(3)*tr_seri(i,k,id_codu)+
    225 !     .               ss_dustsco(3)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
    226       IF(id_fine>0) taue865_tr2(i)=taue865_tr2(i)
    227      .                +alpha_acc*tr_seri(i,k,id_fine)*
    228      .                 zdz(i,k)*1.e6
    229       IF(id_coss>0) taue865_ss(i)=taue865_ss(i)+
    230      .                ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)*
    231      .                zdz(i,k)*1.e6
    232       IF(id_codu>0)  taue865_dust(i)=taue865_dust(i)
    233      .                +ss_dust(3)*tr_seri(i,k,id_codu)*
    234      .                zdz(i,k)*1.e6
    235       IF(id_scdu>0)  taue865_dustsco(i)=taue865_dustsco(i)+
    236      .                ss_dustsco(3)*tr_seri(i,k,id_scdu)*
    237      .                zdz(i,k)*1.e6
    238 
    239 
    240 c
    241       IF(id_coss>0)  burden_ss(i)=burden_ss(i)
    242      .                +tr_seri(i,k,id_coss)*1.e6*1.e3*zdz(i,k)
    243       ENDDO            !-loop on klev
    244       ENDDO            !-loop on klon
    245 !      print *,'tr_seri = ',SUM(tr_seri(:,:,3)),MINVAL(tr_seri(:,:,3)),
    246 !     .                                          MAXVAL(tr_seri(:,:,3))
    247 !      print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
    248 !     .                                        MAXVAL(taue550_ss)
    249 c
    250       RETURN
    251       END
     1SUBROUTINE aeropt_spl(zdz, tr_seri, RHcl, &
     2        id_prec, id_fine, id_coss, id_codu, id_scdu, &
     3        ok_chimeredust, &
     4        ztaue550, ztaue670, ztaue865, &
     5        taue550_tr2, taue670_tr2, taue865_tr2, &
     6        taue550_ss, taue670_ss, taue865_ss, &
     7        taue550_dust, taue670_dust, taue865_dust, &
     8        taue550_dustsco, taue670_dustsco, taue865_dustsco)
     9  !
     10  USE dimphy
     11  USE infotrac
     12  IMPLICIT none
     13  !
     14  INCLUDE "chem.h"
     15  INCLUDE "dimensions.h"
     16  INCLUDE "YOMCST.h"
     17  !
     18  ! Arguments:
     19  !
     20  !======================== INPUT ==================================
     21  REAL :: zdz(klon, klev)
     22  REAL :: tr_seri(klon, klev, nbtr) ! masse of tracer
     23  REAL :: RHcl(klon, klev)     ! humidite relativen ciel clair
     24  INTEGER :: id_prec, id_fine, id_coss, id_codu, id_scdu
     25  LOGICAL :: ok_chimeredust
     26  !============================== OUTPUT =================================
     27  REAL :: ztaue550(klon) ! epaisseur optique aerosol 550 nm
     28  REAL :: ztaue670(klon) ! epaisseur optique aerosol 670 nm
     29  REAL :: ztaue865(klon) ! epaisseur optique aerosol 865 nm
     30  REAL :: taue550_tr2(klon) ! epaisseur optique aerosol 550 nm, diagnostic
     31  REAL :: taue670_tr2(klon) ! epaisseur optique aerosol 670 nm, diagnostic
     32  REAL :: taue865_tr2(klon) ! epaisseur optique aerosol 865 nm, diagnostic
     33  REAL :: taue550_ss(klon) ! epaisseur optique aerosol 550 nm, diagnostic
     34  REAL :: taue670_ss(klon) ! epaisseur optique aerosol 670 nm, diagnostic
     35  REAL :: taue865_ss(klon) ! epaisseur optique aerosol 865 nm, diagnostic
     36  REAL :: taue550_dust(klon) ! epaisseur optique aerosol 550 nm, diagnostic
     37  REAL :: taue670_dust(klon) ! epaisseur optique aerosol 670 nm, diagnostic
     38  REAL :: taue865_dust(klon) ! epaisseur optique aerosol 865 nm, diagnostic
     39  REAL :: taue550_dustsco(klon) ! epaisseur optique aerosol 550 nm, diagnostic
     40  REAL :: taue670_dustsco(klon) ! epaisseur optique aerosol 670 nm, diagnostic
     41  REAL :: taue865_dustsco(klon) ! epaisseur optique aerosol 865 nm, diagnostic
     42  !===================== LOCAL VARIABLES ===========================
     43  INTEGER :: nb_lambda, nbre_RH
     44  PARAMETER (nb_lambda = 3, nbre_RH = 12)
     45  INTEGER :: i, k, RH_num
     46  REAL :: rh, RH_MAX, DELTA, RH_tab(nbre_RH)
     47  PARAMETER (RH_MAX = 95.)
     48  INTEGER :: rh_int
     49  PARAMETER (rh_int = 12)
     50  REAL :: auxreal
     51  ! REAL ss_a(nb_lambda,int,nbtr-1)
     52  ! DATA ss_a/72*1./
     53  REAL :: ss_dust(nb_lambda), ss_acc550(rh_int), alpha_acc
     54  REAL :: ss_dustsco(nb_lambda)
     55  REAL :: ss_acc670(rh_int), ss_acc865(rh_int)
     56  REAL :: ss_ssalt550(rh_int)
     57  REAL :: ss_ssalt670(rh_int), ss_ssalt865(rh_int)
     58  REAL :: burden_ss(klon)
     59  DATA ss_acc550 /3.135, 3.135, 3.135, 3.135, 4.260, 4.807, &
     60          5.546, 6.651, 8.641, 10.335, 13.534, 22.979/
     61  DATA ss_acc670 /2.220, 2.220, 2.220, 2.220, 3.048, 3.460, &
     62          4.023, 4.873, 6.426, 7.761, 10.322, 18.079/
     63  DATA ss_acc865 /1.329, 1.329, 1.329, 1.329, 1.855, 2.124, &
     64          2.494, 3.060, 4.114, 5.033, 6.831, 12.457/
     65  !old4tracers      DATA ss_dust/0.564, 0.614, 0.700/ !for bin 0.5-10um
     66  ! DATA ss_dust/0.553117, 0.610185, 0.7053460 / !for bin 0.5-3um radius
     67  ! DATA ss_dustsco/0.1014, 0.102156, 0.1035538 / !for bin 3-15um radius
     68  !20140902      DATA ss_dust/0.5345737, 0.5878828, 0.6772957/ !for bin 0.5-3um radius
     69  !20140902      DATA ss_dustsco/0.1009634, 0.1018700, 0.1031178/ !for bin 3-15um radius
     70  !3days      DATA ss_dust/0.4564216, 0.4906738, 0.5476248/ !for bin 0.5-3um radius
     71  !3days      DATA ss_dustsco/0.1015022, 0.1024051, 0.1036622/ !for bin 3-15um radius
     72  !JE20140911      DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
     73  !JE20140911      DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
     74  !JE20140915      DATA ss_dust/0.3188754,0.3430106,0.3829019/ !for bin 0.5-5um radius
     75  !JE20140915      DATA ss_dustsco/8.0582686E-02,8.1255026E-02,8.1861295E-02/ !for bin 5-15um radius
     76
     77  ! DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
     78  ! DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
     79
     80  DATA ss_ssalt550/0.182, 0.182, 0.182, 0.182, 0.366, 0.430, &
     81          0.484, 0.551, 0.648, 0.724, 0.847, 1.218/ !for bin 0.5-20 um, fit_v2
     82  DATA ss_ssalt670/0.193, 0.193, 0.193, 0.193, 0.377, 0.431, &
     83          0.496, 0.587, 0.693, 0.784, 0.925, 1.257/ !for bin 0.5-20 um
     84  DATA ss_ssalt865/0.188, 0.188, 0.188, 0.188, 0.384, 0.443, &
     85          0.502, 0.580, 0.699, 0.799, 0.979, 1.404/ !for bin 0.5-20 um
     86
     87  DATA RH_tab/0., 10., 20., 30., 40., 50., 60., 70., 80., 85., 90., 95./
     88  !
     89  IF (ok_chimeredust) THEN
     90    !JE20150212<< : changes in ustar in dustmod changes emission distribution
     91    ! ss_dust=(/0.5167768,0.5684330,0.6531643/)
     92    ! ss_dustsco=(/0.1003391,0.1012288,0.1024651/)
     93    ! JE20150618: Change in dustmodule, div3 is now =6: change distributions
     94    ! div3=3      ss_dust   =(/0.4670522 , 0.5077308 , 0.5745184/)
     95    ! div3=3      ss_dustsco=(/0.099858  , 0.1007395 , 0.1019673/)
     96    ss_dust = (/0.4851232, 0.5292494, 0.5935509/)
     97    ss_dustsco = (/0.1001981, 0.1011043, 0.1023113/)
     98
     99    !JE20150212>>
     100
     101  ELSE
     102    ss_dust = (/0.564, 0.614, 0.700/)
     103    ss_dustsco = (/0., 0., 0./)
     104  ENDIF
     105
     106  DO i = 1, klon
     107    ztaue550(i) = 0.0
     108    ztaue670(i) = 0.0
     109    ztaue865(i) = 0.0
     110    taue550_tr2(i) = 0.0
     111    taue670_tr2(i) = 0.0
     112    taue865_tr2(i) = 0.0
     113    taue550_ss(i) = 0.0
     114    taue670_ss(i) = 0.0
     115    taue865_ss(i) = 0.0
     116    taue550_dust(i) = 0.0
     117    taue670_dust(i) = 0.0
     118    taue865_dust(i) = 0.0
     119    taue550_dustsco(i) = 0.0
     120    taue670_dustsco(i) = 0.0
     121    taue865_dustsco(i) = 0.0
     122    burden_ss(i) = 0.0
     123  ENDDO
     124
     125  DO k = 1, klev
     126    DO i = 1, klon
     127      !
     128      rh = MIN(RHcl(i, k) * 100., RH_MAX)
     129      RH_num = INT(rh / 10. + 1.)
     130      IF (rh>85.) RH_num = 10
     131      IF (rh>90.) RH_num = 11
     132      ! IF (rh.gt.40.) THEN
     133      !     RH_num=5   ! Added by NHL temporarily
     134      !     print *,'TEMPORARY CASE'
     135      ! ENDIF
     136      DELTA = (rh - RH_tab(RH_num)) / (RH_tab(RH_num + 1) - RH_tab(RH_num))
     137
     138
     139      !*******************************************************************
     140      ! AOD at 550 NM
     141      !*******************************************************************
     142      alpha_acc = ss_acc550(RH_num) + DELTA * (ss_acc550(RH_num + 1) - &
     143              ss_acc550(RH_num))              !--m2/g
     144      !nhl_test TOTAL AOD
     145      auxreal = 0.
     146      IF(id_fine>0) auxreal = auxreal + alpha_acc * tr_seri(i, k, id_fine)
     147      IF(id_coss>0) auxreal = auxreal + ss_ssalt550(RH_num) * &
     148              tr_seri(i, k, id_coss)
     149      IF(id_codu>0) auxreal = auxreal + ss_dust(1) * tr_seri(i, k, id_codu)
     150      IF(id_scdu>0) auxreal = auxreal + ss_dustsco(1) * tr_seri(i, k, id_scdu)
     151      ztaue550(i) = ztaue550(i) + auxreal * zdz(i, k) * 1.e6
     152
     153      !JE20150128        ztaue550(i)=ztaue550(i)+(alpha_acc*tr_seri(i,k,id_fine)+
     154      ! .                 ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)+
     155      ! .                 ss_dust(1)*tr_seri(i,k,id_codu)+
     156      ! .              ss_dustsco(1)*tr_seri(i,k,id_scdu)  )*zdz(i,k)*1.e6
     157
     158      !nhl_test TOTAL AOD IS NOW AOD COARSE MODE ONLY
     159      !nhl_test        ztaue550(i)=ztaue550(i)+(
     160      !nhl_test     .                 ss_ssalt550(RH_num)*tr_seri(i,k,3)+
     161      !nhl_test     .                 ss_dust(1)*tr_seri(i,k,4))*zdz(i,k)*1.e6
     162
     163      IF(id_fine>0) taue550_tr2(i) = taue550_tr2(i) &
     164              + alpha_acc * tr_seri(i, k, id_fine) * zdz(i, k) * 1.e6
     165      IF(id_coss>0) taue550_ss(i) = taue550_ss(i) + &
     166              ss_ssalt550(RH_num) * tr_seri(i, k, id_coss) * &
     167                      zdz(i, k) * 1.e6
     168      IF(id_codu>0) taue550_dust(i) = taue550_dust(i) + &
     169              ss_dust(1) * tr_seri(i, k, id_codu) * &
     170                      zdz(i, k) * 1.e6
     171      IF(id_scdu>0) taue550_dustsco(i) = taue550_dustsco(i) + &
     172              ss_dustsco(1) * tr_seri(i, k, id_scdu) * &
     173                      zdz(i, k) * 1.e6
     174      ! print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
     175      ! .                                          MAXVAL(taue550_ss)
     176
     177      !*******************************************************************
     178      !                   AOD at 670 NM
     179      !*******************************************************************
     180      alpha_acc = ss_acc670(RH_num) + DELTA * (ss_acc670(RH_num + 1) - &
     181              ss_acc670(RH_num))              !--m2/g
     182      auxreal = 0.
     183      IF(id_fine>0) auxreal = auxreal + alpha_acc * tr_seri(i, k, id_fine)
     184      IF(id_coss>0) auxreal = auxreal + ss_ssalt670(RH_num) &
     185              * tr_seri(i, k, id_coss)
     186      IF(id_codu>0) auxreal = auxreal + ss_dust(2) * tr_seri(i, k, id_codu)
     187      IF(id_scdu>0) auxreal = auxreal + ss_dustsco(2) * tr_seri(i, k, id_scdu)
     188      ztaue670(i) = ztaue670(i) + auxreal * zdz(i, k) * 1.e6
     189
     190      !JE20150128        ztaue670(i)=ztaue670(i)+(alpha_acc*tr_seri(i,k,id_fine)+
     191      ! .                 ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)+
     192      ! .                 ss_dust(2)*tr_seri(i,k,id_codu)+
     193      ! .               ss_dustsco(2)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
     194
     195      IF(id_fine>0)  taue670_tr2(i) = taue670_tr2(i) + &
     196              alpha_acc * tr_seri(i, k, id_fine) * &
     197                      zdz(i, k) * 1.e6
     198      IF(id_coss>0)  taue670_ss(i) = taue670_ss(i) + &
     199              ss_ssalt670(RH_num) * tr_seri(i, k, id_coss) * &
     200                      zdz(i, k) * 1.e6
     201      IF(id_codu>0)  taue670_dust(i) = taue670_dust(i) &
     202              + ss_dust(2) * tr_seri(i, k, id_codu) * &
     203                      zdz(i, k) * 1.e6
     204      IF(id_scdu>0)  taue670_dustsco(i) = taue670_dustsco(i) + &
     205              ss_dustsco(2) * tr_seri(i, k, id_scdu) * &
     206                      zdz(i, k) * 1.e6
     207
     208      !*******************************************************************
     209      ! AOD at 865 NM
     210      !*******************************************************************
     211      alpha_acc = ss_acc865(RH_num) + DELTA * (ss_acc865(RH_num + 1) - &
     212              ss_acc865(RH_num))              !--m2/g
     213      auxreal = 0.
     214      IF(id_fine>0) auxreal = auxreal + alpha_acc * tr_seri(i, k, id_fine)
     215      IF(id_coss>0) auxreal = auxreal &
     216              + ss_ssalt865(RH_num) * tr_seri(i, k, id_coss)
     217      IF(id_codu>0) auxreal = auxreal + ss_dust(3) * tr_seri(i, k, id_codu)
     218      IF(id_scdu>0) auxreal = auxreal + ss_dustsco(3) * tr_seri(i, k, id_scdu)
     219      ztaue865(i) = ztaue865(i) + auxreal * zdz(i, k) * 1.e6
     220      !JE20150128        ztaue865(i)=ztaue865(i)+(alpha_acc*tr_seri(i,k,id_fine)+
     221      ! .                 ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)+
     222      ! .                 ss_dust(3)*tr_seri(i,k,id_codu)+
     223      ! .               ss_dustsco(3)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
     224      IF(id_fine>0) taue865_tr2(i) = taue865_tr2(i) &
     225              + alpha_acc * tr_seri(i, k, id_fine) * &
     226                      zdz(i, k) * 1.e6
     227      IF(id_coss>0) taue865_ss(i) = taue865_ss(i) + &
     228              ss_ssalt865(RH_num) * tr_seri(i, k, id_coss) * &
     229                      zdz(i, k) * 1.e6
     230      IF(id_codu>0)  taue865_dust(i) = taue865_dust(i) &
     231              + ss_dust(3) * tr_seri(i, k, id_codu) * &
     232                      zdz(i, k) * 1.e6
     233      IF(id_scdu>0)  taue865_dustsco(i) = taue865_dustsco(i) + &
     234              ss_dustsco(3) * tr_seri(i, k, id_scdu) * &
     235                      zdz(i, k) * 1.e6
     236
     237
     238      !
     239      IF(id_coss>0)  burden_ss(i) = burden_ss(i) &
     240              + tr_seri(i, k, id_coss) * 1.e6 * 1.e3 * zdz(i, k)
     241    ENDDO            !-loop on klev
     242  ENDDO            !-loop on klon
     243  ! print *,'tr_seri = ',SUM(tr_seri(:,:,3)),MINVAL(tr_seri(:,:,3)),
     244  ! .                                          MAXVAL(tr_seri(:,:,3))
     245  !  print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
     246  ! .                                        MAXVAL(taue550_ss)
     247  !
     248  RETURN
     249END SUBROUTINE aeropt_spl

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/bcscav_spl.f90

    r5103 r5104  
    1       SUBROUTINE bcscav_spl(pdtime,flxr,flxs,alpha_r,alpha_s,x,dx)
     1SUBROUTINE bcscav_spl(pdtime, flxr, flxs, alpha_r, alpha_s, x, dx)
    22
    3       USE dimphy
    4       IMPLICIT NONE
    5 c=====================================================================
    6 c Objet : below-cloud scavenging of tracers
    7 c Date : september 1999
    8 c Auteur: O. Boucher (LOA)
    9 c=====================================================================
    10 c
    11       INCLUDE "dimensions.h"
    12       INCLUDE "chem.h"
    13       INCLUDE "YOMCST.h"
    14       INCLUDE "YOECUMF.h"
    15 c
    16       REAL pdtime, alpha_r, alpha_s, R_r, R_s
    17       PARAMETER (R_r=0.001)          !--mean raindrop radius (m)
    18       PARAMETER (R_s=0.001)          !--mean snow crystal radius (m)
    19       REAL flxr(klon,klev)         ! liquid precipitation rate (kg/m2/s)
    20       REAL flxs(klon,klev)         ! solid  precipitation rate (kg/m2/s)
    21       REAL flxr_aux(klon,klev+1)
    22       REAL flxs_aux(klon,klev+1)
    23       REAL x(klon,klev)              ! q de traceur 
    24       REAL dx(klon,klev)             ! tendance de traceur
    25 c
    26 c--variables locales     
    27       INTEGER i, k
    28       REAL pr, ps, ice, water
    29 c
    30 c------------------------------------------
    31 c
    32 ! NHL
    33 ! Auxiliary variables defined to deal with the fact that precipitation
    34 ! fluxes are defined on klev levels only.
    35 ! NHL
     3  USE dimphy
     4  IMPLICIT NONE
     5  !=====================================================================
     6  ! Objet : below-cloud scavenging of tracers
     7  ! Date : september 1999
     8  ! Auteur: O. Boucher (LOA)
     9  !=====================================================================
     10  !
     11  INCLUDE "dimensions.h"
     12  INCLUDE "chem.h"
     13  INCLUDE "YOMCST.h"
     14  INCLUDE "YOECUMF.h"
     15  !
     16  REAL :: pdtime, alpha_r, alpha_s, R_r, R_s
     17  PARAMETER (R_r = 0.001)          !--mean raindrop radius (m)
     18  PARAMETER (R_s = 0.001)          !--mean snow crystal radius (m)
     19  REAL :: flxr(klon, klev)         ! liquid precipitation rate (kg/m2/s)
     20  REAL :: flxs(klon, klev)         ! solid  precipitation rate (kg/m2/s)
     21  REAL :: flxr_aux(klon, klev + 1)
     22  REAL :: flxs_aux(klon, klev + 1)
     23  REAL :: x(klon, klev)              ! q de traceur
     24  REAL :: dx(klon, klev)             ! tendance de traceur
     25  !
     26  !--variables locales
     27  INTEGER :: i, k
     28  REAL :: pr, ps, ice, water
     29  !
     30  !------------------------------------------
     31  !
     32  ! NHL
     33  ! Auxiliary variables defined to deal with the fact that precipitation
     34  ! fluxes are defined on klev levels only.
     35  ! NHL
    3636
    37       flxr_aux(:,klev+1)=0.0
    38       flxs_aux(:,klev+1)=0.0
    39       flxr_aux(:,1:klev)=flxr(:,:)
    40       flxs_aux(:,1:klev)=flxs(:,:)
     37  flxr_aux(:, klev + 1) = 0.0
     38  flxs_aux(:, klev + 1) = 0.0
     39  flxr_aux(:, 1:klev) = flxr(:, :)
     40  flxs_aux(:, 1:klev) = flxs(:, :)
    4141
    42       DO k=1, klev
    43       DO i=1, klon
    44        pr=0.5*(flxr_aux(i,k)+flxr_aux(i,k+1))
    45        ps=0.5*(flxs_aux(i,k)+flxs_aux(i,k+1))
    46        water=pr*alpha_r/R_r/rho_water
    47        ice=ps*alpha_s/R_s/rho_ice
    48        dx(i,k)=-3./4.*x(i,k)*pdtime*(water+ice)
    49 ctmp       dx(i,k)=-3./4.*x(i,k)*pdtime*
    50 ctmp     .         (pr*alpha_r/R_r/rho_water+ps*alpha_s/R_s/rho_ice)
    51       ENDDO
    52       ENDDO
    53 c
    54       RETURN
    55       END
     42  DO k = 1, klev
     43    DO i = 1, klon
     44      pr = 0.5 * (flxr_aux(i, k) + flxr_aux(i, k + 1))
     45      ps = 0.5 * (flxs_aux(i, k) + flxs_aux(i, k + 1))
     46      water = pr * alpha_r / R_r / rho_water
     47      ice = ps * alpha_s / R_s / rho_ice
     48      dx(i, k) = -3. / 4. * x(i, k) * pdtime * (water + ice)
     49      !tmp       dx(i,k)=-3./4.*x(i,k)*pdtime*
     50      !tmp     .         (pr*alpha_r/R_r/rho_water+ps*alpha_s/R_s/rho_ice)
     51    ENDDO
     52  ENDDO
     53  !
     54  RETURN
     55END SUBROUTINE bcscav_spl

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/bl_for_dms.f90

    r5103 r5104  
    1       SUBROUTINE bl_for_dms(u,v,paprs,pplay,cdragh,cdragm
    2      .                     ,t,q,tsol,ustar,obklen)
    3       USE dimphy
    4       IMPLICIT NONE
    5 c
    6 c===================================================================
    7 c Auteur : E. Cosme
    8 c Calcul de la vitesse de friction (ustar) et de la longueur de
    9 c Monin-Obukhov (obklen), necessaires pour calculer les flux de DMS
    10 c par la methode de Nightingale.
    11 c Cette SUBROUTINE est plus que fortement inspiree de la subroutine
    12 c 'nonlocal' dans clmain.F .
    13 c reference :  Holtslag, A.A.M., and B.A. Boville, 1993:
    14 c Local versus nonlocal boundary-layer diffusion in a global climate
    15 c model. J. of Climate, vol. 6, 1825-1842. (a confirmer)
    16 c 31 08 01
    17 c===================================================================
    18 c
    19       INCLUDE "dimensions.h"
    20       INCLUDE "YOMCST.h"
    21       INCLUDE "YOETHF.h"
    22       INCLUDE "FCTTRE.h"
    23 c
    24 c Arguments :
    25       REAL u(klon,klev)          ! vent zonal
    26       REAL v(klon,klev)          ! vent meridien
    27       REAL paprs(klon,klev+1)    ! niveaux de pression aux intercouches (Pa)
    28       REAL pplay(klon,klev)      ! niveaux de pression aux milieux... (Pa)
    29       REAL cdragh(klon)          ! coefficient de trainee pour la chaleur
    30       REAL cdragm(klon)          ! coefficient de trainee pour le vent
    31       REAL t(klon,klev)          ! temperature
    32       REAL q(klon,klev)          ! humidite kg/kg
    33       REAL tsol(klon)            ! temperature du sol
    34       REAL ustar(klon)           ! vitesse de friction
    35       REAL obklen(klon)          ! longueur de Monin-Obukhov
    36 c
    37 c Locales :
    38       REAL vk
    39       PARAMETER (vk=0.35)
    40       REAL beta  ! coefficient d'evaporation reelle (/evapotranspiration)
    41                 ! entre 0 et 1, mais 1 au-dessus de la mer
    42       PARAMETER (beta=1.)
    43       INTEGER i,k
    44       REAL zxt, zxu, zxv, zxq, zxqs, zxmod, taux, tauy
    45       REAL zcor, zdelta, zcvm5
    46       REAL z(klon,klev)
    47       REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
    48       REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
    49       REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
    50       REAL heatv(klon)      ! surface virtual heat flux
     1SUBROUTINE bl_for_dms(u, v, paprs, pplay, cdragh, cdragm &
     2        , t, q, tsol, ustar, obklen)
     3  USE dimphy
     4  IMPLICIT NONE
     5  !
     6  !===================================================================
     7  ! Auteur : E. Cosme
     8  ! Calcul de la vitesse de friction (ustar) et de la longueur de
     9  ! Monin-Obukhov (obklen), necessaires pour calculer les flux de DMS
     10  ! par la methode de Nightingale.
     11  ! Cette SUBROUTINE est plus que fortement inspiree de la subroutine
     12  ! 'nonlocal' dans clmain.F .
     13  ! reference :  Holtslag, A.A.M., and B.A. Boville, 1993:
     14  ! Local versus nonlocal boundary-layer diffusion in a global climate
     15  ! model. J. of Climate, vol. 6, 1825-1842. (a confirmer)
     16  ! 31 08 01
     17  !===================================================================
     18  !
     19  INCLUDE "dimensions.h"
     20  INCLUDE "YOMCST.h"
     21  INCLUDE "YOETHF.h"
     22  INCLUDE "FCTTRE.h"
     23  !
     24  ! Arguments :
     25  REAL :: u(klon, klev)          ! vent zonal
     26  REAL :: v(klon, klev)          ! vent meridien
     27  REAL :: paprs(klon, klev + 1)    ! niveaux de pression aux intercouches (Pa)
     28  REAL :: pplay(klon, klev)      ! niveaux de pression aux milieux... (Pa)
     29  REAL :: cdragh(klon)          ! coefficient de trainee pour la chaleur
     30  REAL :: cdragm(klon)          ! coefficient de trainee pour le vent
     31  REAL :: t(klon, klev)          ! temperature
     32  REAL :: q(klon, klev)          ! humidite kg/kg
     33  REAL :: tsol(klon)            ! temperature du sol
     34  REAL :: ustar(klon)           ! vitesse de friction
     35  REAL :: obklen(klon)          ! longueur de Monin-Obukhov
     36  !
     37  ! Locales :
     38  REAL :: vk
     39  PARAMETER (vk = 0.35)
     40  REAL :: beta  ! coefficient d'evaporation reelle (/evapotranspiration)
     41  ! ! entre 0 et 1, mais 1 au-dessus de la mer
     42  PARAMETER (beta = 1.)
     43  INTEGER :: i, k
     44  REAL :: zxt, zxu, zxv, zxq, zxqs, zxmod, taux, tauy
     45  REAL :: zcor, zdelta, zcvm5
     46  REAL :: z(klon, klev)
     47  REAL :: zx_alf1, zx_alf2 ! parametres pour extrapolation
     48  REAL :: khfs(klon)       ! surface kinematic heat flux [mK/s]
     49  REAL :: kqfs(klon)       ! sfc kinematic constituent flux [m/s]
     50  REAL :: heatv(klon)      ! surface virtual heat flux
    5151
    52      
    53 c
    54 c======================================================================
    55 c
    56 c Calculer les hauteurs de chaque couche
    57 c
    58 ! JE20150707      r2es=611.14 *18.0153/28.9644
    59       DO i = 1, klon
    60          z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
    61      .               * (paprs(i,1)-pplay(i,1)) / RG
    62       ENDDO
    63       DO k = 2, klev
    64       DO i = 1, klon
    65          z(i,k) = z(i,k-1)
    66      .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
    67      .                   * (pplay(i,k-1)-pplay(i,k)) / RG
    68       ENDDO
    69       ENDDO
    7052
    71       DO i = 1, klon
    72 c
    73         zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
    74         zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
    75         zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
    76         zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
    77         zxqs=MIN(0.5,zxqs)
    78         zcor=1./(1.-retv*zxqs)
    79         zxqs=zxqs*zcor
    80 c
    81         zx_alf1 = 1.0
    82         zx_alf2 = 1.0 - zx_alf1
    83         zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
    84      .        *(1.+RETV*q(i,1))*zx_alf1
    85      .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
    86      .        *(1.+RETV*q(i,2))*zx_alf2
    87         zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
    88         zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
    89         zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
    90         zxmod = 1.0+SQRT(zxu**2+zxv**2)
    91         khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cdragh(i)
    92         kqfs(i) = (zxqs-zxq) *zxmod*cdragh(i) * beta
    93         heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
    94         taux = zxu *zxmod*cdragm(i)
    95         tauy = zxv *zxmod*cdragm(i)
    96         ustar(i) = SQRT(taux**2+tauy**2)
    97         ustar(i) = MAX(SQRT(ustar(i)),0.01)
    98 c
    99       ENDDO
    100 c
    101       DO i = 1, klon
    102          obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
    103       ENDDO
    104 c
    105       END SUBROUTINE
     53  !
     54  !======================================================================
     55  !
     56  ! Calculer les hauteurs de chaque couche
     57  !
     58  ! JE20150707      r2es=611.14 *18.0153/28.9644
     59  DO i = 1, klon
     60    z(i, 1) = RD * t(i, 1) / (0.5 * (paprs(i, 1) + pplay(i, 1))) &
     61            * (paprs(i, 1) - pplay(i, 1)) / RG
     62  ENDDO
     63  DO k = 2, klev
     64    DO i = 1, klon
     65      z(i, k) = z(i, k - 1) &
     66              + RD * 0.5 * (t(i, k - 1) + t(i, k)) / paprs(i, k) &
     67                      * (pplay(i, k - 1) - pplay(i, k)) / RG
     68    ENDDO
     69  ENDDO
     70
     71  DO i = 1, klon
     72    !
     73    zdelta = MAX(0., SIGN(1., RTT - tsol(i)))
     74    zcvm5 = R5LES * RLVTT * (1. - zdelta) + R5IES * RLSTT * zdelta
     75    zcvm5 = zcvm5 / RCPD / (1.0 + RVTMP2 * q(i, 1))
     76    zxqs = r2es * FOEEW(tsol(i), zdelta) / paprs(i, 1)
     77    zxqs = MIN(0.5, zxqs)
     78    zcor = 1. / (1. - retv * zxqs)
     79    zxqs = zxqs * zcor
     80    !
     81    zx_alf1 = 1.0
     82    zx_alf2 = 1.0 - zx_alf1
     83    zxt = (t(i, 1) + z(i, 1) * RG / RCPD / (1. + RVTMP2 * q(i, 1))) &
     84            * (1. + RETV * q(i, 1)) * zx_alf1 &
     85            + (t(i, 2) + z(i, 2) * RG / RCPD / (1. + RVTMP2 * q(i, 2))) &
     86                    * (1. + RETV * q(i, 2)) * zx_alf2
     87    zxu = u(i, 1) * zx_alf1 + u(i, 2) * zx_alf2
     88    zxv = v(i, 1) * zx_alf1 + v(i, 2) * zx_alf2
     89    zxq = q(i, 1) * zx_alf1 + q(i, 2) * zx_alf2
     90    zxmod = 1.0 + SQRT(zxu**2 + zxv**2)
     91    khfs(i) = (tsol(i) * (1. + RETV * q(i, 1)) - zxt) * zxmod * cdragh(i)
     92    kqfs(i) = (zxqs - zxq) * zxmod * cdragh(i) * beta
     93    heatv(i) = khfs(i) + 0.61 * zxt * kqfs(i)
     94    taux = zxu * zxmod * cdragm(i)
     95    tauy = zxv * zxmod * cdragm(i)
     96    ustar(i) = SQRT(taux**2 + tauy**2)
     97    ustar(i) = MAX(SQRT(ustar(i)), 0.01)
     98    !
     99  ENDDO
     100  !
     101  DO i = 1, klon
     102    obklen(i) = -t(i, 1) * ustar(i)**3 / (RG * vk * heatv(i))
     103  ENDDO
     104  !
     105END SUBROUTINE

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/blcloud_scav.f90

    r5103 r5104  
    1 c Subroutine that calculates the effect of precipitation in scavenging
    2 c BELOW the cloud, for large scale as well as convective precipitation
    3       SUBROUTINE blcloud_scav(lminmax,qmin,qmax,pdtphys,prfl,psfl,
    4      .                        pmflxr,pmflxs,zdz,alpha_r,alpha_s,masse,
    5      .                                  his_dhbclsc,his_dhbccon,tr_seri)
     1! Subroutine that calculates the effect of precipitation in scavenging
     2! BELOW the cloud, for large scale as well as convective precipitation
     3SUBROUTINE blcloud_scav(lminmax, qmin, qmax, pdtphys, prfl, psfl, &
     4        pmflxr, pmflxs, zdz, alpha_r, alpha_s, masse, &
     5        his_dhbclsc, his_dhbccon, tr_seri)
    66
    7       USE dimphy
    8       USE indice_sol_mod
    9       USE infotrac
    10       IMPLICIT NONE
     7  USE dimphy
     8  USE indice_sol_mod
     9  USE infotrac
     10  IMPLICIT NONE
    1111
    12       INCLUDE "dimensions.h"
    13       INCLUDE "chem.h"
    14       INCLUDE "YOMCST.h"
    15       INCLUDE "paramet.h"
     12  INCLUDE "dimensions.h"
     13  INCLUDE "chem.h"
     14  INCLUDE "YOMCST.h"
     15  INCLUDE "paramet.h"
    1616
    17 c============================= INPUT ===================================
    18       REAL qmin,qmax
    19       REAL pdtphys  ! pas d'integration pour la physique (seconde)
    20 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
    21 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
    22       REAL alpha_r(nbtr)!--coefficient d'impaction pour la pluie
    23       REAL alpha_s(nbtr)!--coefficient d'impaction pour la neige     
    24       REAL masse(nbtr)
    25       LOGICAL lminmax
    26       REAL zdz(klon,klev)
    27       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
    28       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
    29 c============================= OUTPUT ==================================
    30       REAL tr_seri(klon,klev,nbtr) ! traceur
    31       REAL aux_var1(klon,klev) ! traceur
    32       REAL aux_var2(klon,klev) ! traceur
    33       REAL his_dhbclsc(klon,nbtr), his_dhbccon(klon,nbtr)
    34 c========================= LOCAL VARIABLES =============================     
    35       INTEGER it, k, i, j
    36       REAL d_tr(klon,klev,nbtr)
     17  !============================= INPUT ===================================
     18  REAL :: qmin, qmax
     19  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     20  ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
     21  ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
     22  REAL :: alpha_r(nbtr)!--coefficient d'impaction pour la pluie
     23  REAL :: alpha_s(nbtr)!--coefficient d'impaction pour la neige
     24  REAL :: masse(nbtr)
     25  LOGICAL :: lminmax
     26  REAL :: zdz(klon, klev)
     27  REAL :: prfl(klon, klev + 1), psfl(klon, klev + 1)     !--large-scale  ! Titane
     28  REAL :: pmflxr(klon, klev + 1), pmflxs(klon, klev + 1)   !--convection   ! Titane
     29  !============================= OUTPUT ==================================
     30  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     31  REAL :: aux_var1(klon, klev) ! traceur
     32  REAL :: aux_var2(klon, klev) ! traceur
     33  REAL :: his_dhbclsc(klon, nbtr), his_dhbccon(klon, nbtr)
     34  !========================= LOCAL VARIABLES =============================
     35  INTEGER :: it, k, i, j
     36  REAL :: d_tr(klon, klev, nbtr)
    3737
    38       EXTERNAL minmaxqfi, bcscav_spl
    39      
    40       DO it=1, nbtr
    41 c
    42       DO j=1,klev
    43       DO i=1,klon
    44         aux_var1(i,j)=tr_seri(i,j,it)
    45         aux_var2(i,j)=d_tr(i,j,it)
     38  EXTERNAL minmaxqfi, bcscav_spl
     39
     40  DO it = 1, nbtr
     41    !
     42    DO j = 1, klev
     43      DO i = 1, klon
     44        aux_var1(i, j) = tr_seri(i, j, it)
     45        aux_var2(i, j) = d_tr(i, j, it)
    4646      ENDDO
     47    ENDDO
     48    !
     49    !nhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
     50    !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
     51    CALL bcscav_spl(pdtphys, prfl, psfl, alpha_r(it), alpha_s(it), &
     52            aux_var1, aux_var2)
     53    !
     54    DO j = 1, klev
     55      DO i = 1, klon
     56        tr_seri(i, j, it) = aux_var1(i, j)
     57        d_tr(i, j, it) = aux_var2(i, j)
    4758      ENDDO
    48 c
    49 cnhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
    50 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
    51       CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
    52      .                aux_var1,aux_var2)
    53 c
    54       DO j=1,klev
    55       DO i=1,klon
    56         tr_seri(i,j,it)=aux_var1(i,j)
    57         d_tr(i,j,it)=aux_var2(i,j)
     59    ENDDO
     60    DO k = 1, klev
     61      DO i = 1, klon
     62        tr_seri(i, k, it) = tr_seri(i, k, it) + d_tr(i, k, it)
     63        his_dhbclsc(i, it) = his_dhbclsc(i, it) - d_tr(i, k, it) / RNAVO * &
     64                masse(it) * 1.e3 * 1.e6 * zdz(i, k) / pdtphys  !--mgS/m2/s
     65
    5866      ENDDO
     67    ENDDO
     68    !
     69    DO i = 1, klon
     70      DO j = 1, klev
     71        aux_var1(i, j) = tr_seri(i, j, it)
     72        aux_var2(i, j) = d_tr(i, j, it)
    5973      ENDDO
    60       DO k = 1, klev
    61       DO i = 1, klon
    62          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
    63          his_dhbclsc(i,it)=his_dhbclsc(i,it)-d_tr(i,k,it)/RNAVO*
    64      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys  !--mgS/m2/s
    65              
    66       ENDDO
    67       ENDDO
    68 c
    69       DO i=1,klon
    70       DO j=1,klev
    71         aux_var1(i,j)=tr_seri(i,j,it)
    72         aux_var2(i,j)=d_tr(i,j,it)
    73       ENDDO
    74       ENDDO
    75 c
    76       IF (lminmax) THEN
    77         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc lsc')
    78 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
    79       ENDIF
    80 c
    81 c-scheme for convective scavenging
    82 c
    83 cnhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
    84 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
     74    ENDDO
     75    !
     76    IF (lminmax) THEN
     77      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide bc lsc')
     78      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
     79    ENDIF
     80    !
     81    !-scheme for convective scavenging
     82    !
     83    !nhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
     84    !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
     85
     86    CALL bcscav_spl(pdtphys, pmflxr, pmflxs, alpha_r(it), alpha_s(it), &
     87            aux_var1, aux_var2)
    8588
    8689
    87       CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
    88      .                aux_var1,aux_var2)
    89 
    90 
    91 c
    92       DO i=1,klon
    93       DO j=1,klev
    94         tr_seri(i,j,it)=aux_var1(i,j)
    95         d_tr(i,j,it)=aux_var2(i,j)
     90    !
     91    DO i = 1, klon
     92      DO j = 1, klev
     93        tr_seri(i, j, it) = aux_var1(i, j)
     94        d_tr(i, j, it) = aux_var2(i, j)
    9695      ENDDO
     96    ENDDO
     97    !
     98    DO k = 1, klev
     99      DO i = 1, klon
     100        tr_seri(i, k, it) = tr_seri(i, k, it) + d_tr(i, k, it)
     101        his_dhbccon(i, it) = his_dhbccon(i, it) - d_tr(i, k, it) / RNAVO * &
     102                masse(it) * 1.e3 * 1.e6 * zdz(i, k) / pdtphys    !--mgS/m2/s
    97103      ENDDO
    98 c
    99       DO k = 1, klev
    100       DO i = 1, klon
    101          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
    102          his_dhbccon(i,it)=his_dhbccon(i,it)-d_tr(i,k,it)/RNAVO*
    103      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys    !--mgS/m2/s
     104    ENDDO
     105    !
     106    IF (lminmax) THEN
     107      DO j = 1, klev
     108        DO i = 1, klon
     109          aux_var1(i, j) = tr_seri(i, j, it)
     110        ENDDO
    104111      ENDDO
     112      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide bc con')
     113      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
     114      DO j = 1, klev
     115        DO i = 1, klon
     116          tr_seri(i, j, it) = aux_var1(i, j)
     117        ENDDO
    105118      ENDDO
    106 c
    107       IF (lminmax) THEN
    108         DO j=1,klev
    109         DO i=1,klon
    110           aux_var1(i,j)=tr_seri(i,j,it)
    111         ENDDO
    112         ENDDO
    113         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc con')
    114 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
    115         DO j=1,klev
    116         DO i=1,klon
    117           tr_seri(i,j,it)=aux_var1(i,j)
    118         ENDDO
    119         ENDDO
    120       ENDIF
    121 c
    122 c
    123       ENDDO !--boucle sur it
    124 c
    125       END
     119    ENDIF
     120    !
     121    !
     122  ENDDO !--boucle sur it
     123  !
     124END SUBROUTINE blcloud_scav

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/blcloud_scav_lsc.f90

    r5103 r5104  
    1 c Subroutine that calculates the effect of precipitation in scavenging
    2 c BELOW the cloud, for large scale as well as convective precipitation
    3       SUBROUTINE blcloud_scav_lsc(lminmax,qmin,qmax,pdtphys,prfl,psfl,
    4      .                        pmflxr,pmflxs,zdz,alpha_r,alpha_s,masse,
    5      .                                  his_dhbclsc,his_dhbccon,tr_seri)
     1! Subroutine that calculates the effect of precipitation in scavenging
     2! BELOW the cloud, for large scale as well as convective precipitation
     3SUBROUTINE blcloud_scav_lsc(lminmax, qmin, qmax, pdtphys, prfl, psfl, &
     4        pmflxr, pmflxs, zdz, alpha_r, alpha_s, masse, &
     5        his_dhbclsc, his_dhbccon, tr_seri)
    66
    7       USE dimphy
    8       USE indice_sol_mod
    9       USE infotrac
    10       IMPLICIT NONE
     7  USE dimphy
     8  USE indice_sol_mod
     9  USE infotrac
     10  IMPLICIT NONE
    1111
    12       INCLUDE "dimensions.h"
    13       INCLUDE "chem.h"
    14       INCLUDE "YOMCST.h"
    15       INCLUDE "paramet.h"
     12  INCLUDE "dimensions.h"
     13  INCLUDE "chem.h"
     14  INCLUDE "YOMCST.h"
     15  INCLUDE "paramet.h"
    1616
    17 c============================= INPUT ===================================
    18       REAL qmin,qmax
    19       REAL pdtphys  ! pas d'integration pour la physique (seconde)
    20 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
    21 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
    22       REAL alpha_r(nbtr)!--coefficient d'impaction pour la pluie
    23       REAL alpha_s(nbtr)!--coefficient d'impaction pour la neige     
    24       REAL masse(nbtr)
    25       LOGICAL lminmax
    26       REAL zdz(klon,klev)
    27       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
    28       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
    29 c============================= OUTPUT ==================================
    30       REAL tr_seri(klon,klev,nbtr) ! traceur
    31       REAL aux_var1(klon,klev) ! traceur
    32       REAL aux_var2(klon,klev) ! traceur
    33       REAL his_dhbclsc(klon,nbtr), his_dhbccon(klon,nbtr)
    34 c========================= LOCAL VARIABLES =============================     
    35       INTEGER it, k, i, j
    36       REAL d_tr(klon,klev,nbtr)
     17  !============================= INPUT ===================================
     18  REAL :: qmin, qmax
     19  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     20  ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
     21  ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
     22  REAL :: alpha_r(nbtr)!--coefficient d'impaction pour la pluie
     23  REAL :: alpha_s(nbtr)!--coefficient d'impaction pour la neige
     24  REAL :: masse(nbtr)
     25  LOGICAL :: lminmax
     26  REAL :: zdz(klon, klev)
     27  REAL :: prfl(klon, klev + 1), psfl(klon, klev + 1)     !--large-scale  ! Titane
     28  REAL :: pmflxr(klon, klev + 1), pmflxs(klon, klev + 1)   !--convection   ! Titane
     29  !============================= OUTPUT ==================================
     30  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     31  REAL :: aux_var1(klon, klev) ! traceur
     32  REAL :: aux_var2(klon, klev) ! traceur
     33  REAL :: his_dhbclsc(klon, nbtr), his_dhbccon(klon, nbtr)
     34  !========================= LOCAL VARIABLES =============================
     35  INTEGER :: it, k, i, j
     36  REAL :: d_tr(klon, klev, nbtr)
    3737
    38       EXTERNAL minmaxqfi, bcscav_spl
    39      
    40       DO it=1, nbtr
    41 c
    42       DO j=1,klev
    43       DO i=1,klon
    44         aux_var1(i,j)=tr_seri(i,j,it)
    45         aux_var2(i,j)=d_tr(i,j,it)
     38  EXTERNAL minmaxqfi, bcscav_spl
     39
     40  DO it = 1, nbtr
     41    !
     42    DO j = 1, klev
     43      DO i = 1, klon
     44        aux_var1(i, j) = tr_seri(i, j, it)
     45        aux_var2(i, j) = d_tr(i, j, it)
    4646      ENDDO
     47    ENDDO
     48    !
     49    !nhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
     50    !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
     51    CALL bcscav_spl(pdtphys, prfl, psfl, alpha_r(it), alpha_s(it), &
     52            aux_var1, aux_var2)
     53    !
     54    DO j = 1, klev
     55      DO i = 1, klon
     56        tr_seri(i, j, it) = aux_var1(i, j)
     57        d_tr(i, j, it) = aux_var2(i, j)
    4758      ENDDO
    48 c
    49 cnhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
    50 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
    51       CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
    52      .                aux_var1,aux_var2)
    53 c
    54       DO j=1,klev
    55       DO i=1,klon
    56         tr_seri(i,j,it)=aux_var1(i,j)
    57         d_tr(i,j,it)=aux_var2(i,j)
     59    ENDDO
     60    DO k = 1, klev
     61      DO i = 1, klon
     62        tr_seri(i, k, it) = tr_seri(i, k, it) + d_tr(i, k, it)
     63        his_dhbclsc(i, it) = his_dhbclsc(i, it) - d_tr(i, k, it) / RNAVO * &
     64                masse(it) * 1.e3 * 1.e6 * zdz(i, k) / pdtphys  !--mgS/m2/s
     65
    5866      ENDDO
     67    ENDDO
     68    !
     69    DO i = 1, klon
     70      DO j = 1, klev
     71        aux_var1(i, j) = tr_seri(i, j, it)
     72        aux_var2(i, j) = d_tr(i, j, it)
    5973      ENDDO
    60       DO k = 1, klev
    61       DO i = 1, klon
    62          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
    63          his_dhbclsc(i,it)=his_dhbclsc(i,it)-d_tr(i,k,it)/RNAVO*
    64      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys  !--mgS/m2/s
    65              
    66       ENDDO
    67       ENDDO
    68 c
    69       DO i=1,klon
    70       DO j=1,klev
    71         aux_var1(i,j)=tr_seri(i,j,it)
    72         aux_var2(i,j)=d_tr(i,j,it)
    73       ENDDO
    74       ENDDO
    75 c
    76       IF (lminmax) THEN
    77         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc lsc')
    78 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
    79       ENDIF
    80 c
    81 c-scheme for convective scavenging
    82 c
    83 cnhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
    84 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
     74    ENDDO
     75    !
     76    IF (lminmax) THEN
     77      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide bc lsc')
     78      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
     79    ENDIF
     80    !
     81    !-scheme for convective scavenging
     82    !
     83    !nhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
     84    !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
    8585
    8686
    87 cJE      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
    88 cJE     .                aux_var1,aux_var2)
     87    !JE      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
     88    !JE     .                aux_var1,aux_var2)
    8989
    9090
    91 c
    92       DO i=1,klon
    93       DO j=1,klev
    94         tr_seri(i,j,it)=aux_var1(i,j)
    95         d_tr(i,j,it)=aux_var2(i,j)
     91    !
     92    DO i = 1, klon
     93      DO j = 1, klev
     94        tr_seri(i, j, it) = aux_var1(i, j)
     95        d_tr(i, j, it) = aux_var2(i, j)
    9696      ENDDO
     97    ENDDO
     98    !
     99    DO k = 1, klev
     100      DO i = 1, klon
     101        tr_seri(i, k, it) = tr_seri(i, k, it) + d_tr(i, k, it)
     102        his_dhbccon(i, it) = his_dhbccon(i, it) - d_tr(i, k, it) / RNAVO * &
     103                masse(it) * 1.e3 * 1.e6 * zdz(i, k) / pdtphys    !--mgS/m2/s
    97104      ENDDO
    98 c
    99       DO k = 1, klev
    100       DO i = 1, klon
    101          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
    102          his_dhbccon(i,it)=his_dhbccon(i,it)-d_tr(i,k,it)/RNAVO*
    103      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys    !--mgS/m2/s
     105    ENDDO
     106    !
     107    IF (lminmax) THEN
     108      DO j = 1, klev
     109        DO i = 1, klon
     110          aux_var1(i, j) = tr_seri(i, j, it)
     111        ENDDO
    104112      ENDDO
     113      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide bc con')
     114      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
     115      DO j = 1, klev
     116        DO i = 1, klon
     117          tr_seri(i, j, it) = aux_var1(i, j)
     118        ENDDO
    105119      ENDDO
    106 c
    107       IF (lminmax) THEN
    108         DO j=1,klev
    109         DO i=1,klon
    110           aux_var1(i,j)=tr_seri(i,j,it)
    111         ENDDO
    112         ENDDO
    113         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc con')
    114 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
    115         DO j=1,klev
    116         DO i=1,klon
    117           tr_seri(i,j,it)=aux_var1(i,j)
    118         ENDDO
    119         ENDDO
    120       ENDIF
    121 c
    122 c
    123       ENDDO !--boucle sur it
    124 c
    125       END
     120    ENDIF
     121    !
     122    !
     123  ENDDO !--boucle sur it
     124  !
     125END SUBROUTINE blcloud_scav_lsc

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/coarsemission.f90

    r5103 r5104  
    1 c This SUBROUTINE calculates the emissions of SEA SALT and DUST, part of
    2 C which goes to tracer 2 and other part to tracer 3.
    3       SUBROUTINE coarsemission(pctsrf,pdtphys,
    4      .                         t_seri,pmflxr,pmflxs,prfl,psfl,
    5      .                         xlat,xlon,debutphy,
    6      .                         zu10m,zv10m,wstar,ale_bl,ale_wake,
    7      .                         scale_param_ssacc,scale_param_sscoa,
    8      .                         scale_param_dustacc,scale_param_dustcoa,
    9      .                         scale_param_dustsco,
    10      .                         nbreg_dust,
    11      .                         iregion_dust,dust_ec,
    12      .                  param_wstarBLperregion,param_wstarWAKEperregion,
    13      .                  nbreg_wstardust,
    14      .                  iregion_wstardust,
    15      .                         lmt_sea_salt,qmin,qmax,
    16      .                             flux_sparam_ddfine,flux_sparam_ddcoa,
    17      .                             flux_sparam_ddsco,
    18      .                             flux_sparam_ssfine,flux_sparam_sscoa,
    19      .                          id_prec,id_fine,id_coss,id_codu,id_scdu,
    20      .                          ok_chimeredust,
    21      .                                                source_tr,flux_tr)
    22 !     .                         wth,cly,zprecipinsoil,lmt_sea_salt,
    23 
    24 !      CALL dustemission( debutphy, xlat, xlon, pctsrf,
    25 !     .               zu10m     zv10m,wstar,ale_bl,ale_wake)
    26 
    27       USE dimphy
    28       USE indice_sol_mod
    29       USE infotrac
    30       USE dustemission_mod,  ONLY: dustemission
    31 !      USE phytracr_spl_mod, ONLY: nbreg_dust, nbreg_ind, nbreg_bb
    32       IMPLICIT NONE
    33 
    34       INCLUDE "dimensions.h"
    35       INCLUDE "chem.h"
    36       INCLUDE "chem_spla.h"
    37       INCLUDE "YOMCST.h"
    38       INCLUDE "paramet.h"
    39      
    40 c============================== INPUT ==================================
    41       INTEGER nbjour
    42       LOGICAL ok_chimeredust
    43       REAL pdtphys  ! pas d'integration pour la physique (seconde)
    44       REAL t_seri(klon,klev)  ! temperature
    45       REAL pctsrf(klon,nbsrf)
    46       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
    47 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
    48       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
    49 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
    50       LOGICAL debutphy, lafinphy
    51       REAL, intent(in) ::  xlat(klon)    ! latitudes pour chaque point
    52       REAL, intent(in) ::  xlon(klon)    ! longitudes pour chaque point
    53       REAL,DIMENSION(klon),INTENT(IN)    :: zu10m
    54       REAL,DIMENSION(klon),INTENT(IN)    :: zv10m
    55       REAL,DIMENSION(klon),INTENT(IN)    :: wstar,Ale_bl,ale_wake
    56 
    57 c
    58 c------------------------- Scaling Parameters --------------------------
    59 c
    60       INTEGER iregion_dust(klon) !Defines  dust regions
    61       REAL scale_param_ssacc  !Scaling parameter for Fine Sea Salt
    62       REAL scale_param_sscoa  !Scaling parameter for Coarse Sea Salt
    63       REAL scale_param_dustacc(nbreg_dust)  !Scaling parameter for Fine Dust
    64       REAL scale_param_dustcoa(nbreg_dust)  !Scaling parameter for Coarse Dust
    65       REAL scale_param_dustsco(nbreg_dust)  !Scaling parameter for SCoarse Dust
    66 !JE20141124<<
    67       INTEGER iregion_wstardust(klon) !Defines dust regions in terms of wstar
    68       REAL param_wstarBLperregion(nbreg_wstardust)  !
    69       REAL param_wstarWAKEperregion(nbreg_wstardust)  !
    70       REAL param_wstarBL(klon)  !parameter for surface wind correction..
    71       REAL param_wstarWAKE(klon)  !parameter for surface wind correction..
    72       INTEGER  nbreg_wstardust
    73 !JE20141124>>
    74       INTEGER  nbreg_dust
    75       INTEGER, INTENT(IN) :: id_prec,id_fine,id_coss,id_codu,id_scdu
    76 c============================== OUTPUT =================================
    77       REAL source_tr(klon,nbtr)
    78       REAL flux_tr(klon,nbtr)
    79       REAL flux_sparam_ddfine(klon), flux_sparam_ddcoa(klon)
    80       REAL flux_sparam_ddsco(klon)
    81       REAL flux_sparam_ssfine(klon), flux_sparam_sscoa(klon)
    82 c=========================== LOCAL VARIABLES ===========================           
    83       INTEGER i, j
    84       REAL pct_ocean(klon)
    85 !      REAL zprecipinsoil(klon)
    86 !      REAL cly(klon), wth(klon)
    87       REAL clyfac, avgdryrate, drying
    88            
    89 c---------------------------- SEA SALT emissions ------------------------
    90       REAL lmt_sea_salt(klon,ss_bins) !Sea salt 0.03-8.0 um                         
    91 c
    92 c--------vent 10 m CEPMMT
    93 c
    94       REAL dust_ec(klon)
    95 
    96       real tmp_var2(klon,nbtr) ! auxiliary variable to replace source
    97       REAL qmin, qmax
    98 !----------------------DUST Sahara ---------------
    99       REAL, DIMENSION(klon) :: dustsourceacc,dustsourcecoa,dustsourcesco
    100       INTEGER, DIMENSION(klon) :: maskd
    101 C*********************** DUST EMMISSIONS *******************************
    102 c
    103      
    104 !     avgdryrate=300./365.*pdtphys/86400.
    105 c
    106 !     DO i=1, klon
    107 c
    108 !       IF (cly(i).LT.9990..AND.wth(i).LT.9990.) THEN
    109 !        zprecipinsoil(i)=zprecipinsoil(i) +
    110 !    .        (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
    111 c
    112 !        clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
    113 !        drying=avgdryrate*exp(0.03905491*
    114 !    .                    exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
    115 !        zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
    116 c         
    117 !       ENDIF
    118 c
    119 !     ENDDO
    120 c               
    121 c ==================== CALCULATING DUST EMISSIONS ======================
    122 c
    123 !      IF (lminmax) THEN
    124       DO j=1,nbtr
    125       DO i=1,klon
    126          tmp_var2(i,j)=source_tr(i,j)
    127       ENDDO
    128       ENDDO
    129       CALL minmaxsource(tmp_var2,qmin,qmax,'src: before DD emiss')
    130 !      print *,'Source = ',SUM(source_tr),MINVAL(source_tr),
    131 !     .                                     MAXVAL(source_tr)
    132 !      ENDIF
    133 
    134 c
    135       IF (.NOT. ok_chimeredust)  THEN 
    136       DO i=1, klon
    137 !!     IF (cly(i).GE.9990..OR.wth(i).GE.9990..OR.
    138 !!    .    t_seri(i,1).LE.273.15.OR.zprecipinsoil(i).GT.1.e-8) THEN
    139 !!          dust_ec(i)=0.0
    140 !!     ENDIF
    141 !c Corresponds to dust_emission.EQ.3       
    142 !!!!!!!****************AQUIIIIIIIIIIIIIIIIIIIIIIIIIIII
    143 !! Original line (4 tracers)
    144 !JE<<  old 4 tracer(nhl scheme)        source_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
    145 !     .                  dust_ec(i)*1.e3*0.093   ! g/m2/s
    146 !         source_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
    147 !     .                  dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
    148 !! Original line (4 tracers)
    149 !         flux_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
    150 !     .                  dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
    151 !         flux_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
    152 !     .                  dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
    153 !         flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
    154 !     .                            dust_ec(i)*1.e3*0.093*1.e3
    155 !         flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
    156 !     .                            dust_ec(i)*1.e3*0.905*1.e3
    157       IF(id_fine>0)     source_tr(i,id_fine)=
    158      . scale_param_dustacc(iregion_dust(i))*
    159      .                  dust_ec(i)*1.e3*0.093   ! g/m2/s
    160       IF(id_codu>0)   source_tr(i,id_codu)=
    161      . scale_param_dustcoa(iregion_dust(i))*
    162      .                  dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
    163       IF(id_scdu>0)  source_tr(i,id_scdu)=0.   ! no supercoarse
    164 ! Original line (4 tracers)
    165        IF(id_fine>0)   flux_tr(i,id_fine)=
    166      .  scale_param_dustacc(iregion_dust(i))*
    167      .                  dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
    168        IF(id_codu>0)  flux_tr(i,id_codu)=
    169      . scale_param_dustcoa(iregion_dust(i))*
    170      .                  dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
    171        IF(id_scdu>0) flux_tr(i,id_scdu)=0.
    172 
    173          flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
    174      .                            dust_ec(i)*1.e3*0.093*1.e3
    175          flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
    176      .                            dust_ec(i)*1.e3*0.905*1.e3
    177          flux_sparam_ddsco(i)=0.
    178       ENDDO
    179       ENDIF
    180 !*****************NEW CHIMERE DUST EMISSION Sahara*****
    181 ! je  20140522
    182       IF(ok_chimeredust) THEN
    183       print *,'MIX- NEW SAHARA DUST SOURCE SCHEME...'
    184 
    185       DO i=1,klon
    186       param_wstarBL(i)  =param_wstarBLperregion(iregion_wstardust(i))
    187       param_wstarWAKE(i)=param_wstarWAKEperregion(iregion_wstardust(i))
    188       ENDDO
    189 
    190 
    191       CALL dustemission( debutphy, xlat, xlon, pctsrf,
    192      .                  zu10m,zv10m,wstar,ale_bl,ale_wake,
    193      .                  param_wstarBL, param_wstarWAKE,
    194      .                  dustsourceacc,dustsourcecoa,
    195      .                  dustsourcesco,maskd)
    196      
    197       DO i=1,klon   
    198          if (maskd(i)>0) then
    199       IF(id_fine>0)    source_tr(i,id_fine)=
    200      . scale_param_dustacc(iregion_dust(i))*
    201      .                  dustsourceacc(i)*1.e3   ! g/m2/s  bin 0.03-0.5
    202       IF(id_codu>0)    source_tr(i,id_codu)=
    203      . scale_param_dustcoa(iregion_dust(i))*
    204      .                  dustsourcecoa(i)*1.e3   ! g/m2/s   bin 0.5-3um
    205       IF(id_scdu>0)   source_tr(i,id_scdu)=
    206      . scale_param_dustsco(iregion_dust(i))*
    207      .                  dustsourcesco(i)*1.e3   ! g/m2/s   bin 3-15um
    208 ! Original line (4 tracers)
    209        IF(id_fine>0)  flux_tr(i,id_fine)=
    210      .  scale_param_dustacc(iregion_dust(i))*
    211      .                  dustsourceacc(i)*1.e3*1.e3  !mg/m2/s
    212        IF(id_codu>0)  flux_tr(i,id_codu)=
    213      . scale_param_dustcoa(iregion_dust(i))*
    214      .                  dustsourcecoa(i)*1.e3*1.e3  !mg/m2/s bin 0.5-3um
    215        IF(id_scdu>0)  flux_tr(i,id_scdu)=
    216      . scale_param_dustsco(iregion_dust(i))*
    217      .                  dustsourcesco(i)*1.e3*1.e3  !mg/m2/s bin 3-15um
    218          flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
    219      .                            dustsourceacc(i)*1.e3*1.e3
    220          flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
    221      .                            dustsourcecoa(i)*1.e3*1.e3
    222          flux_sparam_ddsco(i)=scale_param_dustsco(iregion_dust(i)) *
    223      .                            dustsourcesco(i)*1.e3*1.e3
    224          else
    225         IF(id_fine>0) source_tr(i,id_fine)=
    226      .  scale_param_dustacc(iregion_dust(i))*
    227      .                  dust_ec(i)*1.e3*0.114   ! g/m2/s
    228         IF(id_codu>0) source_tr(i,id_codu)=
    229      .  scale_param_dustcoa(iregion_dust(i))*
    230      .                  dust_ec(i)*1.e3*0.108   ! g/m2/s   bin 0.5-3um
    231         IF(id_scdu>0) source_tr(i,id_scdu)=
    232      .  scale_param_dustsco(iregion_dust(i))*
    233      .                  dust_ec(i)*1.e3*0.778   ! g/m2/s   bin 3-15um
    234 ! Original line (4 tracers)
    235         IF(id_fine>0) flux_tr(i,id_fine)=
    236      . scale_param_dustacc(iregion_dust(i))*
    237      .                  dust_ec(i)*1.e3*0.114*1.e3  !mg/m2/s
    238         IF(id_codu>0) flux_tr(i,id_codu)=
    239      . scale_param_dustcoa(iregion_dust(i))*
    240      .                  dust_ec(i)*1.e3*0.108*1.e3  !mg/m2/s bin 0.5-3um
    241         IF(id_scdu>0) flux_tr(i,id_scdu)=
    242      . scale_param_dustsco(iregion_dust(i))*
    243      .                  dust_ec(i)*1.e3*0.778*1.e3  !mg/m2/s bin 0.5-3um
    244 
    245          flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
    246      .                            dust_ec(i)*1.e3*0.114*1.e3
    247          flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
    248      .                            dust_ec(i)*1.e3*0.108*1.e3
    249          flux_sparam_ddsco(i)=scale_param_dustsco(iregion_dust(i)) *
    250      .                            dust_ec(i)*1.e3*0.778*1.e3
    251 
    252          endif
    253       ENDDO
    254 
    255 
    256 
    257 
    258 
    259       ENDIF
    260 !*****************************************************                                   
    261 C******************* SEA SALT EMMISSIONS *******************************
    262       DO i=1,klon
    263          pct_ocean(i)=pctsrf(i,is_oce)
    264       ENDDO
    265 c
    266 !      IF (lminmax) THEN
    267       DO j=1,nbtr
    268       DO i=1,klon
    269          tmp_var2(i,j)=source_tr(i,j)
    270       ENDDO
    271       ENDDO
    272       CALL minmaxsource(tmp_var2,qmin,qmax,'src: before SS emiss')
    273       IF(id_coss>0) then
    274       print *,'Source = ',SUM(source_tr(:,id_coss)),
    275      .     MINVAL(source_tr(:,id_coss)), MAXVAL(source_tr(:,id_coss))
    276       ENDIF
    277 
    278       DO i=1,klon
    279 ! Original line (4 tracers)
    280          IF(id_fine>0) source_tr(i,id_fine)=
    281      . source_tr(i,id_fine)+scale_param_ssacc*
    282      .                                 lmt_sea_salt(i,1)*1.e4       !g/m2/s
    283 
    284 ! Original line (4 tracers)
    285        IF(id_fine>0)  flux_tr(i,id_fine)=
    286      . flux_tr(i,id_fine)+scale_param_ssacc
    287      .                            *lmt_sea_salt(i,1)*1.e4*1.e3      !mg/m2/s
    288 
    289       IF(id_coss>0)  source_tr(i,id_coss)=
    290      . scale_param_sscoa*lmt_sea_salt(i,2)*1.e4    !g/m2/s
    291       IF(id_coss>0)  flux_tr(i,id_coss)=
    292      . scale_param_sscoa*lmt_sea_salt(i,2)*1.e4*1.e3 !mg/m2/s
    293 c
    294          flux_sparam_ssfine(i)=scale_param_ssacc *
    295      .                                  lmt_sea_salt(i,1)*1.e4*1.e3
    296          flux_sparam_sscoa(i)=scale_param_sscoa *
    297      .                                  lmt_sea_salt(i,2)*1.e4*1.e3
    298       ENDDO
    299 !      IF (lminmax) THEN
    300       DO j=1,nbtr
    301       DO i=1,klon
    302          tmp_var2(i,j)=source_tr(i,j)
    303       ENDDO
    304       ENDDO
    305       CALL minmaxsource(tmp_var2,qmin,qmax,'src: after SS emiss')
    306       IF(id_coss>0) then
    307       print *,'Source = ',SUM(source_tr(:,id_coss)),
    308      .  MINVAL(source_tr(:,id_coss)), MAXVAL(source_tr(:,id_coss))
    309       ENDIF
    310 c     
    311 
    312       END
     1! This SUBROUTINE calculates the emissions of SEA SALT and DUST, part of
     2! which goes to tracer 2 and other part to tracer 3.
     3SUBROUTINE coarsemission(pctsrf, pdtphys, &
     4        t_seri, pmflxr, pmflxs, prfl, psfl, &
     5        xlat, xlon, debutphy, &
     6        zu10m, zv10m, wstar, ale_bl, ale_wake, &
     7        scale_param_ssacc, scale_param_sscoa, &
     8        scale_param_dustacc, scale_param_dustcoa, &
     9        scale_param_dustsco, &
     10        nbreg_dust, &
     11        iregion_dust, dust_ec, &
     12        param_wstarBLperregion, param_wstarWAKEperregion, &
     13        nbreg_wstardust, &
     14        iregion_wstardust, &
     15        lmt_sea_salt, qmin, qmax, &
     16        flux_sparam_ddfine, flux_sparam_ddcoa, &
     17        flux_sparam_ddsco, &
     18        flux_sparam_ssfine, flux_sparam_sscoa, &
     19        id_prec, id_fine, id_coss, id_codu, id_scdu, &
     20        ok_chimeredust, &
     21        source_tr, flux_tr)
     22  ! .                         wth,cly,zprecipinsoil,lmt_sea_salt,
     23
     24  !  CALL dustemission( debutphy, xlat, xlon, pctsrf,
     25  ! .               zu10m     zv10m,wstar,ale_bl,ale_wake)
     26
     27  USE dimphy
     28  USE indice_sol_mod
     29  USE infotrac
     30  USE dustemission_mod, ONLY: dustemission
     31  ! USE phytracr_spl_mod, ONLY: nbreg_dust, nbreg_ind, nbreg_bb
     32  IMPLICIT NONE
     33
     34  INCLUDE "dimensions.h"
     35  INCLUDE "chem.h"
     36  INCLUDE "chem_spla.h"
     37  INCLUDE "YOMCST.h"
     38  INCLUDE "paramet.h"
     39
     40  !============================== INPUT ==================================
     41  INTEGER :: nbjour
     42  LOGICAL :: ok_chimeredust
     43  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     44  REAL :: t_seri(klon, klev)  ! temperature
     45  REAL :: pctsrf(klon, nbsrf)
     46  REAL :: pmflxr(klon, klev + 1), pmflxs(klon, klev + 1)   !--convection
     47  ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
     48  REAL :: prfl(klon, klev + 1), psfl(klon, klev + 1)     !--large-scale
     49  ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
     50  LOGICAL :: debutphy, lafinphy
     51  REAL, intent(in) :: xlat(klon)    ! latitudes pour chaque point
     52  REAL, intent(in) :: xlon(klon)    ! longitudes pour chaque point
     53  REAL, DIMENSION(klon), INTENT(IN) :: zu10m
     54  REAL, DIMENSION(klon), INTENT(IN) :: zv10m
     55  REAL, DIMENSION(klon), INTENT(IN) :: wstar, Ale_bl, ale_wake
     56
     57  !
     58  !------------------------- Scaling Parameters --------------------------
     59  !
     60  INTEGER :: iregion_dust(klon) !Defines  dust regions
     61  REAL :: scale_param_ssacc  !Scaling parameter for Fine Sea Salt
     62  REAL :: scale_param_sscoa  !Scaling parameter for Coarse Sea Salt
     63  REAL :: scale_param_dustacc(nbreg_dust)  !Scaling parameter for Fine Dust
     64  REAL :: scale_param_dustcoa(nbreg_dust)  !Scaling parameter for Coarse Dust
     65  REAL :: scale_param_dustsco(nbreg_dust)  !Scaling parameter for SCoarse Dust
     66  !JE20141124<<
     67  INTEGER :: iregion_wstardust(klon) !Defines dust regions in terms of wstar
     68  REAL :: param_wstarBLperregion(nbreg_wstardust)  !
     69  REAL :: param_wstarWAKEperregion(nbreg_wstardust)  !
     70  REAL :: param_wstarBL(klon)  !parameter for surface wind correction..
     71  REAL :: param_wstarWAKE(klon)  !parameter for surface wind correction..
     72  INTEGER :: nbreg_wstardust
     73  !JE20141124>>
     74  INTEGER :: nbreg_dust
     75  INTEGER, INTENT(IN) :: id_prec, id_fine, id_coss, id_codu, id_scdu
     76  !============================== OUTPUT =================================
     77  REAL :: source_tr(klon, nbtr)
     78  REAL :: flux_tr(klon, nbtr)
     79  REAL :: flux_sparam_ddfine(klon), flux_sparam_ddcoa(klon)
     80  REAL :: flux_sparam_ddsco(klon)
     81  REAL :: flux_sparam_ssfine(klon), flux_sparam_sscoa(klon)
     82  !=========================== LOCAL VARIABLES ===========================
     83  INTEGER :: i, j
     84  REAL :: pct_ocean(klon)
     85  ! REAL zprecipinsoil(klon)
     86  ! REAL cly(klon), wth(klon)
     87  REAL :: clyfac, avgdryrate, drying
     88
     89  !---------------------------- SEA SALT emissions ------------------------
     90  REAL :: lmt_sea_salt(klon, ss_bins) !Sea salt 0.03-8.0 um
     91  !
     92  !--------vent 10 m CEPMMT
     93  !
     94  REAL :: dust_ec(klon)
     95
     96  real :: tmp_var2(klon, nbtr) ! auxiliary variable to replace source
     97  REAL :: qmin, qmax
     98  !----------------------DUST Sahara ---------------
     99  REAL, DIMENSION(klon) :: dustsourceacc, dustsourcecoa, dustsourcesco
     100  INTEGER, DIMENSION(klon) :: maskd
     101  !*********************** DUST EMMISSIONS *******************************
     102  !
     103
     104  ! avgdryrate=300./365.*pdtphys/86400.
     105  !
     106  ! DO i=1, klon
     107  !
     108  !   IF (cly(i).LT.9990..AND.wth(i).LT.9990.) THEN
     109  !    zprecipinsoil(i)=zprecipinsoil(i) +
     110  !    .        (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
     111  !
     112  !    clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
     113  !    drying=avgdryrate*exp(0.03905491*
     114  !    .                    exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
     115  !    zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
     116  !
     117  !   ENDIF
     118  !
     119  ! ENDDO
     120  !
     121  ! ==================== CALCULATING DUST EMISSIONS ======================
     122  !
     123  !  IF (lminmax) THEN
     124  DO j = 1, nbtr
     125    DO i = 1, klon
     126      tmp_var2(i, j) = source_tr(i, j)
     127    ENDDO
     128  ENDDO
     129  CALL minmaxsource(tmp_var2, qmin, qmax, 'src: before DD emiss')
     130  ! print *,'Source = ',SUM(source_tr),MINVAL(source_tr),
     131  ! .                                     MAXVAL(source_tr)
     132  !  ENDIF
     133
     134  !
     135  IF (.NOT. ok_chimeredust)  THEN
     136    DO i = 1, klon
     137      !!     IF (cly(i).GE.9990..OR.wth(i).GE.9990..OR.
     138      !!    .    t_seri(i,1).LE.273.15.OR.zprecipinsoil(i).GT.1.e-8) THEN
     139      !!          dust_ec(i)=0.0
     140      !!     ENDIF
     141      !c Corresponds to dust_emission.EQ.3
     142      !!!!!!!****************AQUIIIIIIIIIIIIIIIIIIIIIIIIIIII
     143      !! Original line (4 tracers)
     144      !JE<<  old 4 tracer(nhl scheme)        source_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
     145      ! .                  dust_ec(i)*1.e3*0.093   ! g/m2/s
     146      !     source_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
     147      ! .                  dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
     148      !! Original line (4 tracers)
     149      !     flux_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
     150      ! .                  dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
     151      !     flux_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
     152      ! .                  dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
     153      !     flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
     154      ! .                            dust_ec(i)*1.e3*0.093*1.e3
     155      !     flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
     156      ! .                            dust_ec(i)*1.e3*0.905*1.e3
     157      IF(id_fine>0)     source_tr(i, id_fine) = &
     158              scale_param_dustacc(iregion_dust(i)) * &
     159                      dust_ec(i) * 1.e3 * 0.093   ! g/m2/s
     160      IF(id_codu>0)   source_tr(i, id_codu) = &
     161              scale_param_dustcoa(iregion_dust(i)) * &
     162                      dust_ec(i) * 1.e3 * 0.905   ! g/m2/s   bin 0.5-10um
     163      IF(id_scdu>0)  source_tr(i, id_scdu) = 0.   ! no supercoarse
     164      ! Original line (4 tracers)
     165      IF(id_fine>0)   flux_tr(i, id_fine) = &
     166              scale_param_dustacc(iregion_dust(i)) * &
     167                      dust_ec(i) * 1.e3 * 0.093 * 1.e3  !mg/m2/s
     168      IF(id_codu>0)  flux_tr(i, id_codu) = &
     169              scale_param_dustcoa(iregion_dust(i)) * &
     170                      dust_ec(i) * 1.e3 * 0.905 * 1.e3  !mg/m2/s bin 0.5-10um
     171      IF(id_scdu>0) flux_tr(i, id_scdu) = 0.
     172
     173      flux_sparam_ddfine(i) = scale_param_dustacc(iregion_dust(i)) * &
     174              dust_ec(i) * 1.e3 * 0.093 * 1.e3
     175      flux_sparam_ddcoa(i) = scale_param_dustcoa(iregion_dust(i)) * &
     176              dust_ec(i) * 1.e3 * 0.905 * 1.e3
     177      flux_sparam_ddsco(i) = 0.
     178    ENDDO
     179  ENDIF
     180  !*****************NEW CHIMERE DUST EMISSION Sahara*****
     181  ! je  20140522
     182  IF(ok_chimeredust) THEN
     183    print *, 'MIX- NEW SAHARA DUST SOURCE SCHEME...'
     184
     185    DO i = 1, klon
     186      param_wstarBL(i) = param_wstarBLperregion(iregion_wstardust(i))
     187      param_wstarWAKE(i) = param_wstarWAKEperregion(iregion_wstardust(i))
     188    ENDDO
     189
     190    CALL dustemission(debutphy, xlat, xlon, pctsrf, &
     191            zu10m, zv10m, wstar, ale_bl, ale_wake, &
     192            param_wstarBL, param_wstarWAKE, &
     193            dustsourceacc, dustsourcecoa, &
     194            dustsourcesco, maskd)
     195
     196    DO i = 1, klon
     197      if (maskd(i)>0) then
     198        IF(id_fine>0)    source_tr(i, id_fine) = &
     199                scale_param_dustacc(iregion_dust(i)) * &
     200                        dustsourceacc(i) * 1.e3   ! g/m2/s  bin 0.03-0.5
     201        IF(id_codu>0)    source_tr(i, id_codu) = &
     202                scale_param_dustcoa(iregion_dust(i)) * &
     203                        dustsourcecoa(i) * 1.e3   ! g/m2/s   bin 0.5-3um
     204        IF(id_scdu>0)   source_tr(i, id_scdu) = &
     205                scale_param_dustsco(iregion_dust(i)) * &
     206                        dustsourcesco(i) * 1.e3   ! g/m2/s   bin 3-15um
     207        ! Original line (4 tracers)
     208        IF(id_fine>0)  flux_tr(i, id_fine) = &
     209                scale_param_dustacc(iregion_dust(i)) * &
     210                        dustsourceacc(i) * 1.e3 * 1.e3  !mg/m2/s
     211        IF(id_codu>0)  flux_tr(i, id_codu) = &
     212                scale_param_dustcoa(iregion_dust(i)) * &
     213                        dustsourcecoa(i) * 1.e3 * 1.e3  !mg/m2/s bin 0.5-3um
     214        IF(id_scdu>0)  flux_tr(i, id_scdu) = &
     215                scale_param_dustsco(iregion_dust(i)) * &
     216                        dustsourcesco(i) * 1.e3 * 1.e3  !mg/m2/s bin 3-15um
     217        flux_sparam_ddfine(i) = scale_param_dustacc(iregion_dust(i)) * &
     218                dustsourceacc(i) * 1.e3 * 1.e3
     219        flux_sparam_ddcoa(i) = scale_param_dustcoa(iregion_dust(i)) * &
     220                dustsourcecoa(i) * 1.e3 * 1.e3
     221        flux_sparam_ddsco(i) = scale_param_dustsco(iregion_dust(i)) * &
     222                dustsourcesco(i) * 1.e3 * 1.e3
     223      else
     224        IF(id_fine>0) source_tr(i, id_fine) = &
     225                scale_param_dustacc(iregion_dust(i)) * &
     226                        dust_ec(i) * 1.e3 * 0.114   ! g/m2/s
     227        IF(id_codu>0) source_tr(i, id_codu) = &
     228                scale_param_dustcoa(iregion_dust(i)) * &
     229                        dust_ec(i) * 1.e3 * 0.108   ! g/m2/s   bin 0.5-3um
     230        IF(id_scdu>0) source_tr(i, id_scdu) = &
     231                scale_param_dustsco(iregion_dust(i)) * &
     232                        dust_ec(i) * 1.e3 * 0.778   ! g/m2/s   bin 3-15um
     233        ! Original line (4 tracers)
     234        IF(id_fine>0) flux_tr(i, id_fine) = &
     235                scale_param_dustacc(iregion_dust(i)) * &
     236                        dust_ec(i) * 1.e3 * 0.114 * 1.e3  !mg/m2/s
     237        IF(id_codu>0) flux_tr(i, id_codu) = &
     238                scale_param_dustcoa(iregion_dust(i)) * &
     239                        dust_ec(i) * 1.e3 * 0.108 * 1.e3  !mg/m2/s bin 0.5-3um
     240        IF(id_scdu>0) flux_tr(i, id_scdu) = &
     241                scale_param_dustsco(iregion_dust(i)) * &
     242                        dust_ec(i) * 1.e3 * 0.778 * 1.e3  !mg/m2/s bin 0.5-3um
     243
     244        flux_sparam_ddfine(i) = scale_param_dustacc(iregion_dust(i)) * &
     245                dust_ec(i) * 1.e3 * 0.114 * 1.e3
     246        flux_sparam_ddcoa(i) = scale_param_dustcoa(iregion_dust(i)) * &
     247                dust_ec(i) * 1.e3 * 0.108 * 1.e3
     248        flux_sparam_ddsco(i) = scale_param_dustsco(iregion_dust(i)) * &
     249                dust_ec(i) * 1.e3 * 0.778 * 1.e3
     250
     251      endif
     252    ENDDO
     253
     254  ENDIF
     255  !*****************************************************
     256  !******************* SEA SALT EMMISSIONS *******************************
     257  DO i = 1, klon
     258    pct_ocean(i) = pctsrf(i, is_oce)
     259  ENDDO
     260  !
     261  !  IF (lminmax) THEN
     262  DO j = 1, nbtr
     263    DO i = 1, klon
     264      tmp_var2(i, j) = source_tr(i, j)
     265    ENDDO
     266  ENDDO
     267  CALL minmaxsource(tmp_var2, qmin, qmax, 'src: before SS emiss')
     268  IF(id_coss>0) then
     269    print *, 'Source = ', SUM(source_tr(:, id_coss)), &
     270            MINVAL(source_tr(:, id_coss)), MAXVAL(source_tr(:, id_coss))
     271  ENDIF
     272
     273  DO i = 1, klon
     274    ! Original line (4 tracers)
     275    IF(id_fine>0) source_tr(i, id_fine) = &
     276            source_tr(i, id_fine) + scale_param_ssacc * &
     277                    lmt_sea_salt(i, 1) * 1.e4       !g/m2/s
     278
     279    ! Original line (4 tracers)
     280    IF(id_fine>0)  flux_tr(i, id_fine) = &
     281            flux_tr(i, id_fine) + scale_param_ssacc &
     282                    * lmt_sea_salt(i, 1) * 1.e4 * 1.e3      !mg/m2/s
     283
     284    IF(id_coss>0)  source_tr(i, id_coss) = &
     285            scale_param_sscoa * lmt_sea_salt(i, 2) * 1.e4    !g/m2/s
     286    IF(id_coss>0)  flux_tr(i, id_coss) = &
     287            scale_param_sscoa * lmt_sea_salt(i, 2) * 1.e4 * 1.e3 !mg/m2/s
     288    !
     289    flux_sparam_ssfine(i) = scale_param_ssacc * &
     290            lmt_sea_salt(i, 1) * 1.e4 * 1.e3
     291    flux_sparam_sscoa(i) = scale_param_sscoa * &
     292            lmt_sea_salt(i, 2) * 1.e4 * 1.e3
     293  ENDDO
     294  ! IF (lminmax) THEN
     295  DO j = 1, nbtr
     296    DO i = 1, klon
     297      tmp_var2(i, j) = source_tr(i, j)
     298    ENDDO
     299  ENDDO
     300  CALL minmaxsource(tmp_var2, qmin, qmax, 'src: after SS emiss')
     301  IF(id_coss>0) then
     302    print *, 'Source = ', SUM(source_tr(:, id_coss)), &
     303            MINVAL(source_tr(:, id_coss)), MAXVAL(source_tr(:, id_coss))
     304  ENDIF
     305  !
     306
     307END SUBROUTINE coarsemission

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/deposition.f90

    r5103 r5104  
    1 c Subroutine that estimates the Deposition velocities and the depostion
    2 C for the different tracers
    3       SUBROUTINE deposition(vdep_oce,vdep_sic,vdep_ter,vdep_lic,pctsrf,
    4      .                      zrho,zdz,pdtphys,RHcl,masse,t_seri,pplay,
    5      .                      paprs,lminmax,qmin,qmax,
    6      .                        his_ds,source_tr,tr_seri)
     1! Subroutine that estimates the Deposition velocities and the depostion
     2! for the different tracers
     3SUBROUTINE deposition(vdep_oce, vdep_sic, vdep_ter, vdep_lic, pctsrf, &
     4        zrho, zdz, pdtphys, RHcl, masse, t_seri, pplay, &
     5        paprs, lminmax, qmin, qmax, &
     6        his_ds, source_tr, tr_seri)
    77
    8       USE dimphy
    9       USE infotrac
    10       USE indice_sol_mod
     8  USE dimphy
     9  USE infotrac
     10  USE indice_sol_mod
    1111
    12       IMPLICIT NONE
     12  IMPLICIT NONE
    1313
    14       INCLUDE "dimensions.h"
    15       INCLUDE "chem.h"
    16       INCLUDE "YOMCST.h"
    17       INCLUDE "paramet.h"
     14  INCLUDE "dimensions.h"
     15  INCLUDE "chem.h"
     16  INCLUDE "YOMCST.h"
     17  INCLUDE "paramet.h"
    1818
    19 c----------------------------- INPUT -----------------------------------
    20       LOGICAL lminmax
    21       REAL qmin, qmax
    22       REAL vdep_oce(nbtr), vdep_sic(nbtr)
    23       REAL vdep_ter(nbtr), vdep_lic(nbtr)     
    24       REAL pctsrf(klon,nbsrf)
    25       REAL zrho(klon,klev)        !Density of air at mid points of Z (kg/m3)
    26       REAL zdz(klon,klev)       
    27       REAL pdtphys  ! pas d'integration pour la physique (seconde)
    28       REAL RHcl(klon,klev)  ! humidite relativen ciel clair
    29       REAL t_seri(klon,klev)  ! temperature
    30       REAL pplay(klon,klev)  ! pression pour le mileu de chaque couche (en Pa)
    31       REAL paprs(klon, klev+1)    !pressure at interface of layers Z (Pa)
    32       REAL masse(nbtr)
    33                                          
    34 c----------------------------- OUTPUT ----------------------------------
    35       REAL his_ds(klon,nbtr)                                         
    36       REAL source_tr(klon,nbtr)
    37       REAL tr_seri(klon, klev,nbtr) !conc of tracers
    38 c--------------------- INTERNAL VARIABLES ------------------------------     
    39       INTEGER i, it
    40       REAL vdep        !sed. velocity
     19  !----------------------------- INPUT -----------------------------------
     20  LOGICAL :: lminmax
     21  REAL :: qmin, qmax
     22  REAL :: vdep_oce(nbtr), vdep_sic(nbtr)
     23  REAL :: vdep_ter(nbtr), vdep_lic(nbtr)
     24  REAL :: pctsrf(klon, nbsrf)
     25  REAL :: zrho(klon, klev)        !Density of air at mid points of Z (kg/m3)
     26  REAL :: zdz(klon, klev)
     27  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     28  REAL :: RHcl(klon, klev)  ! humidite relativen ciel clair
     29  REAL :: t_seri(klon, klev)  ! temperature
     30  REAL :: pplay(klon, klev)  ! pression pour le mileu de chaque couche (en Pa)
     31  REAL :: paprs(klon, klev + 1)    !pressure at interface of layers Z (Pa)
     32  REAL :: masse(nbtr)
    4133
    42       DO it=1, nbtr
    43       DO i=1, klon
    44           vdep=vdep_oce(it)*pctsrf(i,is_oce)+
    45      .         vdep_sic(it)*pctsrf(i,is_sic)+
    46      .         vdep_ter(it)*pctsrf(i,is_ter)+
    47      .         vdep_lic(it)*pctsrf(i,is_lic)
    48 c--Unit: molec/m2/s for it=1 to nbtr-3, mg/m2/s for it=nbtr-2 to nbtr
    49           source_tr(i,it)=source_tr(i,it)
    50      .                    -vdep*tr_seri(i,1,it)*zrho(i,1)/1.e2
    51           his_ds(i,it)=vdep*tr_seri(i,1,it)*zrho(i,1)/1.e2
    52      .                 /RNAVO*masse(it)*1.e3               ! mg/m2/s
    53       ENDDO
    54       ENDDO
    55 c
    56       END
     34  !----------------------------- OUTPUT ----------------------------------
     35  REAL :: his_ds(klon, nbtr)
     36  REAL :: source_tr(klon, nbtr)
     37  REAL :: tr_seri(klon, klev, nbtr) !conc of tracers
     38  !--------------------- INTERNAL VARIABLES ------------------------------
     39  INTEGER :: i, it
     40  REAL :: vdep        !sed. velocity
     41
     42  DO it = 1, nbtr
     43    DO i = 1, klon
     44      vdep = vdep_oce(it) * pctsrf(i, is_oce) + &
     45              vdep_sic(it) * pctsrf(i, is_sic) + &
     46              vdep_ter(it) * pctsrf(i, is_ter) + &
     47              vdep_lic(it) * pctsrf(i, is_lic)
     48      !--Unit: molec/m2/s for it=1 to nbtr-3, mg/m2/s for it=nbtr-2 to nbtr
     49      source_tr(i, it) = source_tr(i, it) &
     50              - vdep * tr_seri(i, 1, it) * zrho(i, 1) / 1.e2
     51      his_ds(i, it) = vdep * tr_seri(i, 1, it) * zrho(i, 1) / 1.e2 &
     52              / RNAVO * masse(it) * 1.e3               ! mg/m2/s
     53    ENDDO
     54  ENDDO
     55  !
     56END SUBROUTINE deposition

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/finemission.f90

    r5103 r5104  
    1 C This SUBROUTINE calculates the emissions of BLACK CARBON and ORGANIC
    2 C MATTER
    3       SUBROUTINE finemission(zdz,pdtphys,zalt,kminbc,kmaxbc,
    4      .                       scale_param_bb,scale_param_ff,
    5      .                       iregion_ind,iregion_bb,
    6      .                       nbreg_ind,nbreg_bb,
    7      .                       lmt_bcff,lmt_bcnff,lmt_bcbb_l,lmt_bcbb_h,
    8      .                       lmt_bcba,lmt_omff,lmt_omnff,lmt_ombb_l,
    9      .                       lmt_ombb_h,lmt_omnat,lmt_omba,id_fine,
    10      .                                    flux_sparam_bb,flux_sparam_ff,
    11      .                                        source_tr,flux_tr,tr_seri)
     1! This SUBROUTINE calculates the emissions of BLACK CARBON and ORGANIC
     2! MATTER
     3SUBROUTINE finemission(zdz, pdtphys, zalt, kminbc, kmaxbc, &
     4        scale_param_bb, scale_param_ff, &
     5        iregion_ind, iregion_bb, &
     6        nbreg_ind, nbreg_bb, &
     7        lmt_bcff, lmt_bcnff, lmt_bcbb_l, lmt_bcbb_h, &
     8        lmt_bcba, lmt_omff, lmt_omnff, lmt_ombb_l, &
     9        lmt_ombb_h, lmt_omnat, lmt_omba, id_fine, &
     10        flux_sparam_bb, flux_sparam_ff, &
     11        source_tr, flux_tr, tr_seri)
    1212
    13       USE dimphy
    14       USE indice_sol_mod
    15       USE infotrac
    16 !      USE phytracr_spl_mod, ONLY: nbreg_dust, nbreg_ind, nbreg_bb
    17       IMPLICIT NONE
     13  USE dimphy
     14  USE indice_sol_mod
     15  USE infotrac
     16  ! USE phytracr_spl_mod, ONLY: nbreg_dust, nbreg_ind, nbreg_bb
     17  IMPLICIT NONE
    1818
    19       INCLUDE "dimensions.h"
    20       INCLUDE "chem.h"
    21       INCLUDE "YOMCST.h"
    22       INCLUDE "paramet.h"
     19  INCLUDE "dimensions.h"
     20  INCLUDE "chem.h"
     21  INCLUDE "YOMCST.h"
     22  INCLUDE "paramet.h"
    2323
    24       INTEGER i, k, kminbc, kmaxbc
    25 c============================= INPUT ===================================
    26       REAL pdtphys  ! pas d'integration pour la physique (seconde)
    27       REAL zalt(klon,klev)
    28       REAL zdz(klon,klev)
    29 c
    30 c------------------------- Scaling Parameters --------------------------
    31 c   
    32       INTEGER nbreg_ind,nbreg_bb
    33       INTEGER iregion_ind(klon)  !Defines regions for SO2, BC & OM
    34       INTEGER iregion_bb(klon)   !Defines regions for SO2, BC & OM
    35       REAL scale_param_bb(nbreg_bb) !Scaling parameter for biomas burning
    36       REAL scale_param_ff(nbreg_ind) !Scaling parameter for industrial emissions (fossil fuel)
    37       INTEGER id_fine
    38 c============================= OUTPUT ==================================
    39       REAL source_tr(klon,nbtr)
    40       REAL flux_tr(klon,nbtr)
    41       REAL tr_seri(klon,klev,nbtr) ! traceur
    42       REAL flux_sparam_bb(klon), flux_sparam_ff(klon)
    43 c========================= LOCAL VARIABLES =============================
    44       REAL zzdz
    45 c------------------------- BLACK CARBON emissions ----------------------
    46       REAL lmt_bcff(klon)       ! emissions de BC fossil fuels
    47       REAL lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
    48       REAL lmt_bcbb_l(klon)     ! emissions de BC biomass basses
    49       REAL lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
    50       REAL lmt_bcba(klon)       ! emissions de BC bateau
    51 c------------------------ ORGANIC MATTER emissions ---------------------
    52       REAL lmt_omff(klon)     ! emissions de OM fossil fuels
    53       REAL lmt_omnff(klon)    ! emissions de OM non-fossil fuels
    54       REAL lmt_ombb_l(klon)   ! emissions de OM biomass basses
    55       REAL lmt_ombb_h(klon)   ! emissions de OM biomass hautes
    56       REAL lmt_omnat(klon)    ! emissions de OM Natural
    57       REAL lmt_omba(klon)     ! emissions de OM bateau
    58                                
    59       EXTERNAL condsurfc                               
    60 c========================================================================
    61 c                        LOW LEVEL EMISSIONS
    62 c========================================================================
    63            
    64 c corresponds to bc_source.EQ.3
     24  INTEGER :: i, k, kminbc, kmaxbc
     25  !============================= INPUT ===================================
     26  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     27  REAL :: zalt(klon, klev)
     28  REAL :: zdz(klon, klev)
     29  !
     30  !------------------------- Scaling Parameters --------------------------
     31  !
     32  INTEGER :: nbreg_ind, nbreg_bb
     33  INTEGER :: iregion_ind(klon)  !Defines regions for SO2, BC & OM
     34  INTEGER :: iregion_bb(klon)   !Defines regions for SO2, BC & OM
     35  REAL :: scale_param_bb(nbreg_bb) !Scaling parameter for biomas burning
     36  REAL :: scale_param_ff(nbreg_ind) !Scaling parameter for industrial emissions (fossil fuel)
     37  INTEGER :: id_fine
     38  !============================= OUTPUT ==================================
     39  REAL :: source_tr(klon, nbtr)
     40  REAL :: flux_tr(klon, nbtr)
     41  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     42  REAL :: flux_sparam_bb(klon), flux_sparam_ff(klon)
     43  !========================= LOCAL VARIABLES =============================
     44  REAL :: zzdz
     45  !------------------------- BLACK CARBON emissions ----------------------
     46  REAL :: lmt_bcff(klon)       ! emissions de BC fossil fuels
     47  REAL :: lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
     48  REAL :: lmt_bcbb_l(klon)     ! emissions de BC biomass basses
     49  REAL :: lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
     50  REAL :: lmt_bcba(klon)       ! emissions de BC bateau
     51  !------------------------ ORGANIC MATTER emissions ---------------------
     52  REAL :: lmt_omff(klon)     ! emissions de OM fossil fuels
     53  REAL :: lmt_omnff(klon)    ! emissions de OM non-fossil fuels
     54  REAL :: lmt_ombb_l(klon)   ! emissions de OM biomass basses
     55  REAL :: lmt_ombb_h(klon)   ! emissions de OM biomass hautes
     56  REAL :: lmt_omnat(klon)    ! emissions de OM Natural
     57  REAL :: lmt_omba(klon)     ! emissions de OM bateau
    6558
    66       DO i=1,klon
    67          IF (iregion_ind(i)>0) THEN
    68        IF(id_fine>0)    source_tr(i,id_fine)=source_tr(i,id_fine)+
    69      .                (scale_param_ff(iregion_ind(i))*lmt_bcff(i)+     !g/m2/s
    70      .                 scale_param_ff(iregion_ind(i))*lmt_omff(i)
    71      .                 )     * 1.e4                        !g/m2/s
    72 c
    73       IF(id_fine>0)     flux_tr(i,id_fine)=flux_tr(i,id_fine)+
    74      .                (scale_param_ff(iregion_ind(i))*lmt_bcff(i)+     !mg/m2/s
    75      .                 scale_param_ff(iregion_ind(i))*lmt_omff(i)
    76      .                 )     * 1.e4 *1.e3                  !mg/m2/s
    77 c
    78            flux_sparam_ff(i)= flux_sparam_ff(i) +
    79      .                     scale_param_ff(iregion_ind(i))*
    80      .                     ( lmt_bcff(i)+lmt_omff(i))
    81      .                     *1.e4*1.e3
    82          ENDIF
    83          IF (iregion_bb(i)>0) THEN
    84        IF(id_fine>0)    source_tr(i,id_fine)=source_tr(i,id_fine)+
    85      .                (scale_param_bb(iregion_bb(i))*lmt_bcbb_l(i)+   !g/m2/s
    86      .                 scale_param_bb(iregion_bb(i))*lmt_ombb_l(i)    !g/m2/s
    87      .                 )     * 1.e4                        !g/m2/s
    88 c
    89        IF(id_fine>0)    flux_tr(i,id_fine)=flux_tr(i,id_fine)+
    90      .                (scale_param_bb(iregion_bb(i))*lmt_bcbb_l(i)+   !mg/m2/s
    91      .                 scale_param_bb(iregion_bb(i))*lmt_ombb_l(i)+   !mg/m2/s
    92      .                 scale_param_bb(iregion_bb(i))*lmt_bcbb_h(i)+   !mg/m2/s
    93      .                 scale_param_bb(iregion_bb(i))*lmt_ombb_h(i)    !mg/m2/s
    94      .                 )     * 1.e4 *1.e3                  !mg/m2/s
    95 c
    96            flux_sparam_bb(i)=flux_sparam_bb(i) +
    97      .                   scale_param_bb(iregion_bb(i))*(lmt_bcbb_l(i) +
    98      .                   lmt_bcbb_h(i) + lmt_ombb_l(i) + lmt_ombb_h(i))
    99      .                   *1.e4*1.e3
    100          ENDIF
    101        IF(id_fine>0)  source_tr(i,id_fine)=source_tr(i,id_fine)+
    102      .                (lmt_bcnff(i)+lmt_bcba(i)+lmt_omnff(i)+
    103      .                 lmt_omnat(i)+lmt_omba(i))     * 1.e4           !g/m2/s
    104 c
    105        IF(id_fine>0)  flux_tr(i,id_fine)=flux_tr(i,id_fine)+
    106      .                (lmt_bcnff(i)+lmt_omnff(i)+lmt_omnat(i)+
    107      .                 lmt_omba(i)+lmt_bcba(i))     * 1.e4 *1.e3      !mg/m2/s
    108 c
    109          flux_sparam_ff(i)= flux_sparam_ff(i) +
    110      .                      (lmt_omba(i)+lmt_bcba(i))*1.e4*1.e3
    111       ENDDO
     59  EXTERNAL condsurfc
     60  !========================================================================
     61  ! LOW LEVEL EMISSIONS
     62  !========================================================================
    11263
    113 c========================================================================
    114 c                        HIGH LEVEL EMISSIONS
    115 c========================================================================
    116                              
    117 c  Sources hautes de BC/OM
     64  ! corresponds to bc_source.EQ.3
    11865
    119 c
    120 c HIGH LEVEL EMISSIONS OF SO2 ARE IN PRECUREMISSION.F
    121 c
    122       k=2                             !introducing emissions in level 2
    123 cnhl      DO i = 1, klon
    124 c
    125 cnhl      tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+scale_param_ff(iregion_ind(i))*
    126 cnhl     .               (lmt_bcff_h(i)+lmt_omff_h(i))/zdz(i,k)/100.*pdtphys
    127 c
    128 cnhl      ENDDO
     66  DO i = 1, klon
     67    IF (iregion_ind(i)>0) THEN
     68      IF(id_fine>0)    source_tr(i, id_fine) = source_tr(i, id_fine) + &
     69              (scale_param_ff(iregion_ind(i)) * lmt_bcff(i) + & !g/m2/s
     70                      scale_param_ff(iregion_ind(i)) * lmt_omff(i) &
     71                      ) * 1.e4                        !g/m2/s
     72      !
     73      IF(id_fine>0)     flux_tr(i, id_fine) = flux_tr(i, id_fine) + &
     74              (scale_param_ff(iregion_ind(i)) * lmt_bcff(i) + & !mg/m2/s
     75                      scale_param_ff(iregion_ind(i)) * lmt_omff(i) &
     76                      ) * 1.e4 * 1.e3                  !mg/m2/s
     77      !
     78      flux_sparam_ff(i) = flux_sparam_ff(i) + &
     79              scale_param_ff(iregion_ind(i)) * &
     80                      (lmt_bcff(i) + lmt_omff(i)) &
     81                      * 1.e4 * 1.e3
     82    ENDIF
     83    IF (iregion_bb(i)>0) THEN
     84      IF(id_fine>0)    source_tr(i, id_fine) = source_tr(i, id_fine) + &
     85              (scale_param_bb(iregion_bb(i)) * lmt_bcbb_l(i) + & !g/m2/s
     86                      scale_param_bb(iregion_bb(i)) * lmt_ombb_l(i) & !g/m2/s
     87                      ) * 1.e4                        !g/m2/s
     88      !
     89      IF(id_fine>0)    flux_tr(i, id_fine) = flux_tr(i, id_fine) + &
     90              (scale_param_bb(iregion_bb(i)) * lmt_bcbb_l(i) + & !mg/m2/s
     91                      scale_param_bb(iregion_bb(i)) * lmt_ombb_l(i) + & !mg/m2/s
     92                      scale_param_bb(iregion_bb(i)) * lmt_bcbb_h(i) + & !mg/m2/s
     93                      scale_param_bb(iregion_bb(i)) * lmt_ombb_h(i) & !mg/m2/s
     94                      ) * 1.e4 * 1.e3                  !mg/m2/s
     95      !
     96      flux_sparam_bb(i) = flux_sparam_bb(i) + &
     97              scale_param_bb(iregion_bb(i)) * (lmt_bcbb_l(i) + &
     98                      lmt_bcbb_h(i) + lmt_ombb_l(i) + lmt_ombb_h(i)) &
     99                      * 1.e4 * 1.e3
     100    ENDIF
     101    IF(id_fine>0)  source_tr(i, id_fine) = source_tr(i, id_fine) + &
     102            (lmt_bcnff(i) + lmt_bcba(i) + lmt_omnff(i) + &
     103                    lmt_omnat(i) + lmt_omba(i)) * 1.e4           !g/m2/s
     104    !
     105    IF(id_fine>0)  flux_tr(i, id_fine) = flux_tr(i, id_fine) + &
     106            (lmt_bcnff(i) + lmt_omnff(i) + lmt_omnat(i) + &
     107                    lmt_omba(i) + lmt_bcba(i)) * 1.e4 * 1.e3      !mg/m2/s
     108    !
     109    flux_sparam_ff(i) = flux_sparam_ff(i) + &
     110            (lmt_omba(i) + lmt_bcba(i)) * 1.e4 * 1.e3
     111  ENDDO
    129112
    130       DO k=kminbc, kmaxbc
    131       DO i = 1, klon
    132           zzdz=zalt(i,kmaxbc+1)-zalt(i,kminbc)
    133 c
    134          IF (iregion_bb(i) >0) THEN
    135         IF(id_fine>0)   tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+
    136      .              (scale_param_bb(iregion_bb(i))*lmt_bcbb_h(i)+
    137      .               scale_param_bb(iregion_bb(i))*lmt_ombb_h(i))
    138      .                              /zzdz/100.*pdtphys
    139          ENDIF
    140 c
    141       ENDDO
    142       ENDDO
    143 c
    144       END
     113  !========================================================================
     114  ! HIGH LEVEL EMISSIONS
     115  !========================================================================
     116
     117  !  Sources hautes de BC/OM
     118
     119  !
     120  ! HIGH LEVEL EMISSIONS OF SO2 ARE IN PRECUREMISSION.F
     121  !
     122  k = 2                             !introducing emissions in level 2
     123  !nhl      DO i = 1, klon
     124  !
     125  !nhl      tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+scale_param_ff(iregion_ind(i))*
     126  !nhl     .               (lmt_bcff_h(i)+lmt_omff_h(i))/zdz(i,k)/100.*pdtphys
     127  !
     128  !nhl      ENDDO
     129
     130  DO k = kminbc, kmaxbc
     131    DO i = 1, klon
     132      zzdz = zalt(i, kmaxbc + 1) - zalt(i, kminbc)
     133      !
     134      IF (iregion_bb(i) >0) THEN
     135        IF(id_fine>0)   tr_seri(i, k, id_fine) = tr_seri(i, k, id_fine) + &
     136                (scale_param_bb(iregion_bb(i)) * lmt_bcbb_h(i) + &
     137                        scale_param_bb(iregion_bb(i)) * lmt_ombb_h(i)) &
     138                        / zzdz / 100. * pdtphys
     139      ENDIF
     140      !
     141    ENDDO
     142  ENDDO
     143  !
     144END SUBROUTINE finemission

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/gastoparticle.f90

    r5103 r5104  
    1       SUBROUTINE gastoparticle(pdtphys,zdz,zrho,xlat,pplay,t_seri,
    2      .         id_prec,id_fine,
    3      .         tr_seri,his_g2pgas ,his_g2paer )
    4 cnhl     .                         fluxso4chem, flux_sparam_sulf,
     1SUBROUTINE gastoparticle(pdtphys, zdz, zrho, xlat, pplay, t_seri, &
     2        id_prec, id_fine, &
     3        tr_seri, his_g2pgas, his_g2paer)
     4  !nhl     .                         fluxso4chem, flux_sparam_sulf,
    55
    6       USE dimphy
    7       USE infotrac
    8 c      USE indice_sol_mod
     6  USE dimphy
     7  USE infotrac
     8  ! USE indice_sol_mod
    99
    10       IMPLICIT NONE
    11 c
    12       INCLUDE "dimensions.h"
    13       INCLUDE "chem.h"
    14       INCLUDE "chem_spla.h"
    15       INCLUDE "YOMCST.h"
    16       INCLUDE "YOECUMF.h"
    17 c
    18       REAL pdtphys
    19       REAL zrho(klon,klev)
    20       REAL zdz(klon,klev)
    21       REAL tr_seri(klon,klev,nbtr)   ! traceurs
    22       REAL tend                 ! tendance par espece
    23       REAL xlat(klon)       ! latitudes pour chaque point
    24       REAL pi
    25 c   JE: 20140120
    26       REAL his_g2pgas(klon)
    27       REAL his_g2paer(klon)
    28       REAL tendincm3(klon,klev)
    29       REAL tempvar(klon,klev)     
    30       REAL pplay(klon,klev)
    31       REAL t_seri(klon,klev)
    32       REAL tend2d(klon,klev)
    33       INTEGER id_prec,id_fine
    34 c
    35 c------------------------- Scaling Parameter --------------------------
    36 c
    37 c      REAL scale_param_so4(klon)  !Scaling parameter for sulfate
     10  IMPLICIT NONE
     11  !
     12  INCLUDE "dimensions.h"
     13  INCLUDE "chem.h"
     14  INCLUDE "chem_spla.h"
     15  INCLUDE "YOMCST.h"
     16  INCLUDE "YOECUMF.h"
     17  !
     18  REAL :: pdtphys
     19  REAL :: zrho(klon, klev)
     20  REAL :: zdz(klon, klev)
     21  REAL :: tr_seri(klon, klev, nbtr)   ! traceurs
     22  REAL :: tend                 ! tendance par espece
     23  REAL :: xlat(klon)       ! latitudes pour chaque point
     24  REAL :: pi
     25  !   JE: 20140120
     26  REAL :: his_g2pgas(klon)
     27  REAL :: his_g2paer(klon)
     28  REAL :: tendincm3(klon, klev)
     29  REAL :: tempvar(klon, klev)
     30  REAL :: pplay(klon, klev)
     31  REAL :: t_seri(klon, klev)
     32  REAL :: tend2d(klon, klev)
     33  INTEGER :: id_prec, id_fine
     34  !
     35  !------------------------- Scaling Parameter --------------------------
     36  !
     37  !  REAL scale_param_so4(klon)  !Scaling parameter for sulfate
    3838
    39       INTEGER i, k
    40       REAL tau_chem     !---chemical lifetime in s
    41 c
    42 c------------------------- Variables to save --------------------------
    43 c
    44 cnhl      REAL fluxso4chem(klon,klev)
    45 cnhl      REAL flux_sparam_sulf(klon,klev)
     39  INTEGER :: i, k
     40  REAL :: tau_chem     !---chemical lifetime in s
     41  !
     42  !------------------------- Variables to save --------------------------
     43  !
     44  !nhl      REAL fluxso4chem(klon,klev)
     45  !nhl      REAL flux_sparam_sulf(klon,klev)
    4646
    47 c======================================================================
    48       pi=atan(1.)*4.
    49 c
    50       IF (id_prec>0 .AND. id_fine>0) THEN
    51       DO k = 1, klev
     47  !======================================================================
     48  pi = atan(1.) * 4.
     49  !
     50  IF (id_prec>0 .AND. id_fine>0) THEN
     51    DO k = 1, klev
    5252      DO i = 1, klon
    53 c
    54 c        tau_chem=scale_param_so4(i)*86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
    55 cnhl        tau_chem=86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
    56         tau_chem=86400.*(5.-4.*cos(xlat(i)*pi/180.))    !
    57         tend=tr_seri(i,k,id_prec)*(1.-exp(-pdtphys/tau_chem)) ! Sulfate production
    58 cnhl        tend=(1.-exp(-pdtphys/tau_chem))
    59 cnhl        tend=scale_param_so4(i) !as this it works
    60 c     
    61         tr_seri(i,k,id_prec) =tr_seri(i,k,id_prec) - tend
    62         tr_seri(i,k,id_fine) =tr_seri(i,k,id_fine) +
    63      .                      tend/RNAVO*masse_ammsulfate  !--gAER/KgAir
    64         tend2d(i,k)=tend
    65 c
    66 cnhl        fluxso4chem(i,k) = tend/RNAVO*masse_ammsulfate
    67 cnhl        flux_sparam_sulf(i,k) = tend/RNAVO*masse_ammsulfate
     53        !
     54        !    tau_chem=scale_param_so4(i)*86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
     55        !nhl        tau_chem=86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
     56        tau_chem = 86400. * (5. - 4. * cos(xlat(i) * pi / 180.))    !
     57        tend = tr_seri(i, k, id_prec) * (1. - exp(-pdtphys / tau_chem)) ! Sulfate production
     58        !nhl        tend=(1.-exp(-pdtphys/tau_chem))
     59        !nhl        tend=scale_param_so4(i) !as this it works
     60        !
     61        tr_seri(i, k, id_prec) = tr_seri(i, k, id_prec) - tend
     62        tr_seri(i, k, id_fine) = tr_seri(i, k, id_fine) + &
     63                tend / RNAVO * masse_ammsulfate  !--gAER/KgAir
     64        tend2d(i, k) = tend
     65        !
     66        !nhl        fluxso4chem(i,k) = tend/RNAVO*masse_ammsulfate
     67        !nhl        flux_sparam_sulf(i,k) = tend/RNAVO*masse_ammsulfate
    6868      ENDDO
    69       ENDDO
    70    
     69    ENDDO
    7170
     71    tempvar = tend2d
     72    CALL kg_to_cm3(pplay, t_seri, tempvar)
     73    tendincm3 = tempvar
    7274
    73         tempvar=tend2d
    74          CALL kg_to_cm3(pplay,t_seri,tempvar)
    75         tendincm3=tempvar
    76 
    77       DO k = 1, klev
     75    DO k = 1, klev
    7876      DO i = 1, klon
    7977
    80 c        his_g2pgas(i) = his_g2pgas(i) + tendincm3(i,k)*1e6*zdz(i,k)/pdtphys
    81         his_g2paer(i) = his_g2paer(i) +      
    82      .    tendincm3(i,k)/RNAVO*masse_ammsulfate*1.e3*
    83      .    1.e6*zdz(i,k)/pdtphys    ! mg/m2/s
    84         his_g2pgas(i) = his_g2paer(i)*masse_s/masse_ammsulfate ! mg-S/m2/s
     78        ! his_g2pgas(i) = his_g2pgas(i) + tendincm3(i,k)*1e6*zdz(i,k)/pdtphys
     79        his_g2paer(i) = his_g2paer(i) + &
     80                tendincm3(i, k) / RNAVO * masse_ammsulfate * 1.e3 * &
     81                        1.e6 * zdz(i, k) / pdtphys    ! mg/m2/s
     82        his_g2pgas(i) = his_g2paer(i) * masse_s / masse_ammsulfate ! mg-S/m2/s
    8583
    8684      ENDDO
    87       ENDDO
    88       ENDIF
     85    ENDDO
     86  ENDIF
    8987
    90 c
    91       RETURN
    92       END
     88  !
     89  RETURN
     90END SUBROUTINE gastoparticle

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/incloud_scav.f90

    r5103 r5104  
    1 c Subroutine that calculates the effect of precipitation in scavenging
    2 c WITHIN the cloud, for large scale as well as convective precipitation
    3       SUBROUTINE incloud_scav(lminmax,qmin,qmax,masse,henry,kk,prfl,
    4      .                      psfl,pmflxr,pmflxs,zrho,zdz,t_seri,pdtphys,
    5      .                                   his_dhlsc,his_dhcon1,tr_seri)
     1! Subroutine that calculates the effect of precipitation in scavenging
     2! WITHIN the cloud, for large scale as well as convective precipitation
     3SUBROUTINE incloud_scav(lminmax, qmin, qmax, masse, henry, kk, prfl, &
     4        psfl, pmflxr, pmflxs, zrho, zdz, t_seri, pdtphys, &
     5        his_dhlsc, his_dhcon1, tr_seri)
    66
    7       USE dimphy
    8       USE infotrac
    9       USE indice_sol_mod
     7  USE dimphy
     8  USE infotrac
     9  USE indice_sol_mod
    1010
    11       IMPLICIT NONE
     11  IMPLICIT NONE
    1212
    13       INCLUDE "dimensions.h"
    14       INCLUDE "chem.h"
    15       INCLUDE "YOMCST.h"
    16       INCLUDE "paramet.h"
     13  INCLUDE "dimensions.h"
     14  INCLUDE "chem.h"
     15  INCLUDE "YOMCST.h"
     16  INCLUDE "paramet.h"
    1717
    18 c============================= INPUT ===================================
    19       REAL qmin, qmax
    20       REAL masse(nbtr)
    21       REAL henry(nbtr)         !--cste de Henry  mol/l/atm
    22       REAL kk(nbtr)            !--coefficient de var avec T (K)
    23       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
    24 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
    25       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
    26 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
    27       REAL zrho(klon,klev), zdz(klon,klev)
    28       REAL t_seri(klon,klev)
    29       LOGICAL lminmax
    30       REAL pdtphys
    31 !      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
    32 !      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
    33 c============================= OUTPUT ==================================
    34       REAL tr_seri(klon,klev,nbtr) ! traceur
    35       REAL aux_var1(klon,klev) ! traceur
    36       REAL aux_var2(klon) ! traceur
    37       REAL aux_var3(klon) ! traceur
    38       REAL his_dhlsc(klon,nbtr)        ! in-cloud scavenging lsc
    39       REAL his_dhcon1(klon,nbtr)       ! in-cloud scavenging con
    40 c========================= LOCAL VARIABLES =============================     
    41       INTEGER it, i, j
    42      
    43       EXTERNAL minmaxqfi, inscav_spl
    44      
    45       DO it=1, nbtr
    46 c
    47       DO i=1,klon
    48         aux_var2(i)=his_dhlsc(i,it)
    49         aux_var3(i)=his_dhcon1(i,it)
     18  !============================= INPUT ===================================
     19  REAL :: qmin, qmax
     20  REAL :: masse(nbtr)
     21  REAL :: henry(nbtr)         !--cste de Henry  mol/l/atm
     22  REAL :: kk(nbtr)            !--coefficient de var avec T (K)
     23  REAL :: prfl(klon, klev + 1), psfl(klon, klev + 1)     !--large-scale
     24  ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
     25  REAL :: pmflxr(klon, klev + 1), pmflxs(klon, klev + 1)   !--convection
     26  ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
     27  REAL :: zrho(klon, klev), zdz(klon, klev)
     28  REAL :: t_seri(klon, klev)
     29  LOGICAL :: lminmax
     30  REAL :: pdtphys
     31  ! REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
     32  ! REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
     33  !============================= OUTPUT ==================================
     34  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     35  REAL :: aux_var1(klon, klev) ! traceur
     36  REAL :: aux_var2(klon) ! traceur
     37  REAL :: aux_var3(klon) ! traceur
     38  REAL :: his_dhlsc(klon, nbtr)        ! in-cloud scavenging lsc
     39  REAL :: his_dhcon1(klon, nbtr)       ! in-cloud scavenging con
     40  !========================= LOCAL VARIABLES =============================
     41  INTEGER :: it, i, j
     42
     43  EXTERNAL minmaxqfi, inscav_spl
     44
     45  DO it = 1, nbtr
     46    !
     47    DO i = 1, klon
     48      aux_var2(i) = his_dhlsc(i, it)
     49      aux_var3(i) = his_dhcon1(i, it)
     50    ENDDO
     51    DO j = 1, klev
     52      DO i = 1, klon
     53        aux_var1(i, j) = tr_seri(i, j, it)
    5054      ENDDO
    51       DO j=1,klev
    52       DO i=1,klon
    53         aux_var1(i,j)=tr_seri(i,j,it)
     55    ENDDO
     56    !
     57    IF (lminmax) THEN
     58      CALL minmaxqfi(aux_var1, qmin, qmax, 'avt inscav')
     59      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
     60    ENDIF
     61    !
     62    !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
     63    !nhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
     64    !nhl     .             his_dhlsc(1,it))
     65    CALL inscav_spl(pdtphys, it, masse(it), henry(it), kk(it), 0.5e-3, &
     66            prfl, psfl, zrho, zdz, t_seri, aux_var1, aux_var2)
     67    !
     68    IF (lminmax) THEN
     69      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide lsc')
     70      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
     71    ENDIF
     72    !
     73    !
     74    !-scheme for convective in-cloud scavenging
     75    !
     76    !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
     77    !nhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
     78    !nhl     .             his_dhcon1(1,it))
     79    CALL inscav_spl(pdtphys, it, masse(it), henry(it), kk(it), 1.e-3, &
     80            pmflxr, pmflxs, zrho, zdz, t_seri, aux_var1, aux_var3)
     81    !
     82    IF (lminmax) THEN
     83      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide con')
     84      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
     85    ENDIF
     86    !
     87    DO j = 1, klev
     88      DO i = 1, klon
     89        tr_seri(i, j, it) = aux_var1(i, j)
    5490      ENDDO
    55       ENDDO
    56 c     
    57       IF (lminmax) THEN
    58         CALL minmaxqfi(aux_var1,qmin,qmax,'avt inscav')
    59 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
    60       ENDIF
    61 c
    62 cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
    63 cnhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
    64 cnhl     .             his_dhlsc(1,it))
    65       CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
    66      .             prfl,psfl,zrho,zdz,t_seri,aux_var1,aux_var2)
    67 c
    68       IF (lminmax) THEN
    69         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide lsc')
    70 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
    71       ENDIF
    72 c
    73 c
    74 c-scheme for convective in-cloud scavenging
    75 c
    76 cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
    77 cnhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
    78 cnhl     .             his_dhcon1(1,it))
    79       CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
    80      .             pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
    81 c
    82       IF (lminmax) THEN
    83         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
    84 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
    85       ENDIF
    86 c
    87       DO j=1,klev
    88       DO i=1,klon
    89         tr_seri(i,j,it)=aux_var1(i,j)
    90       ENDDO
    91       ENDDO
    92       DO i=1,klon
    93         his_dhlsc(i,it)=aux_var2(i)
    94         his_dhcon1(i,it)=aux_var3(i)
    95       ENDDO
     91    ENDDO
     92    DO i = 1, klon
     93      his_dhlsc(i, it) = aux_var2(i)
     94      his_dhcon1(i, it) = aux_var3(i)
     95    ENDDO
    9696
    97 c
    98       ENDDO !--boucle sur it
     97    !
     98  ENDDO !--boucle sur it
    9999
    100       END
     100END SUBROUTINE incloud_scav

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/incloud_scav_lsc.f90

    r5103 r5104  
    1 c Subroutine that calculates the effect of precipitation in scavenging
    2 c WITHIN the cloud, for large scale as well as convective precipitation
    3       SUBROUTINE incloud_scav_lsc(lminmax,qmin,qmax,masse,henry,kk,prfl,
    4      .                      psfl,pmflxr,pmflxs,zrho,zdz,t_seri,pdtphys,
    5      .                                   his_dhlsc,his_dhcon1,tr_seri)
     1! Subroutine that calculates the effect of precipitation in scavenging
     2! WITHIN the cloud, for large scale as well as convective precipitation
     3SUBROUTINE incloud_scav_lsc(lminmax, qmin, qmax, masse, henry, kk, prfl, &
     4        psfl, pmflxr, pmflxs, zrho, zdz, t_seri, pdtphys, &
     5        his_dhlsc, his_dhcon1, tr_seri)
    66
    7       USE dimphy
    8       USE infotrac
    9       USE indice_sol_mod
     7  USE dimphy
     8  USE infotrac
     9  USE indice_sol_mod
    1010
    11       IMPLICIT NONE
     11  IMPLICIT NONE
    1212
    13       INCLUDE "dimensions.h"
    14       INCLUDE "chem.h"
    15       INCLUDE "YOMCST.h"
    16       INCLUDE "paramet.h"
     13  INCLUDE "dimensions.h"
     14  INCLUDE "chem.h"
     15  INCLUDE "YOMCST.h"
     16  INCLUDE "paramet.h"
    1717
    18 c============================= INPUT ===================================
    19       REAL qmin, qmax
    20       REAL masse(nbtr)
    21       REAL henry(nbtr)         !--cste de Henry  mol/l/atm
    22       REAL kk(nbtr)            !--coefficient de var avec T (K)
    23       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
    24 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
    25       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
    26 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
    27       REAL zrho(klon,klev), zdz(klon,klev)
    28       REAL t_seri(klon,klev)
    29       LOGICAL lminmax
    30       REAL pdtphys
    31 !      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
    32 !      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
    33 c============================= OUTPUT ==================================
    34       REAL tr_seri(klon,klev,nbtr) ! traceur
    35       REAL aux_var1(klon,klev) ! traceur
    36       REAL aux_var2(klon) ! traceur
    37       REAL aux_var3(klon) ! traceur
    38       REAL his_dhlsc(klon,nbtr)        ! in-cloud scavenging lsc
    39       REAL his_dhcon1(klon,nbtr)       ! in-cloud scavenging con
    40 c========================= LOCAL VARIABLES =============================     
    41       INTEGER it, i, j
    42      
    43       EXTERNAL minmaxqfi, inscav_spl
    44       DO it=1, nbtr
    45 c
    46       DO i=1,klon
    47         aux_var2(i)=his_dhlsc(i,it)
    48         aux_var3(i)=his_dhcon1(i,it)
     18  !============================= INPUT ===================================
     19  REAL :: qmin, qmax
     20  REAL :: masse(nbtr)
     21  REAL :: henry(nbtr)         !--cste de Henry  mol/l/atm
     22  REAL :: kk(nbtr)            !--coefficient de var avec T (K)
     23  REAL :: prfl(klon, klev + 1), psfl(klon, klev + 1)     !--large-scale
     24  ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
     25  REAL :: pmflxr(klon, klev + 1), pmflxs(klon, klev + 1)   !--convection
     26  ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
     27  REAL :: zrho(klon, klev), zdz(klon, klev)
     28  REAL :: t_seri(klon, klev)
     29  LOGICAL :: lminmax
     30  REAL :: pdtphys
     31  ! REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
     32  ! REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
     33  !============================= OUTPUT ==================================
     34  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     35  REAL :: aux_var1(klon, klev) ! traceur
     36  REAL :: aux_var2(klon) ! traceur
     37  REAL :: aux_var3(klon) ! traceur
     38  REAL :: his_dhlsc(klon, nbtr)        ! in-cloud scavenging lsc
     39  REAL :: his_dhcon1(klon, nbtr)       ! in-cloud scavenging con
     40  !========================= LOCAL VARIABLES =============================
     41  INTEGER :: it, i, j
     42
     43  EXTERNAL minmaxqfi, inscav_spl
     44  DO it = 1, nbtr
     45    !
     46    DO i = 1, klon
     47      aux_var2(i) = his_dhlsc(i, it)
     48      aux_var3(i) = his_dhcon1(i, it)
     49    ENDDO
     50    DO j = 1, klev
     51      DO i = 1, klon
     52        aux_var1(i, j) = tr_seri(i, j, it)
    4953      ENDDO
    50       DO j=1,klev
    51       DO i=1,klon
    52         aux_var1(i,j)=tr_seri(i,j,it)
     54    ENDDO
     55    !
     56    IF (lminmax) THEN
     57      CALL minmaxqfi(aux_var1, qmin, qmax, 'avt inscav')
     58      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
     59    ENDIF
     60    !
     61    !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
     62    !nhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
     63    !nhl     .             his_dhlsc(1,it))
     64    CALL inscav_spl(pdtphys, it, masse(it), henry(it), kk(it), 0.5e-3, &
     65            prfl, psfl, zrho, zdz, t_seri, aux_var1, aux_var2)
     66    !
     67    IF (lminmax) THEN
     68      CALL minmaxqfi(aux_var1, qmin, qmax, 'depot humide lsc')
     69      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
     70    ENDIF
     71    !
     72    !
     73    !-scheme for convective in-cloud scavenging
     74    !
     75    !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
     76    !nhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
     77    !nhl     .             his_dhcon1(1,it))
     78
     79    !  print *,'JE inscav0'
     80    !  IF (iflag_con.LT.3) THEN
     81    !
     82    !  print *,'JE inscav1'
     83    !  print *,'iflag_con',iflag_con
     84    !  CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
     85    ! .             pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
     86    !
     87    !c
     88    !  IF (lminmax) THEN
     89    !    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
     90    !cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
     91    !
     92    !  ENDIF
     93    !
     94    !  ENDIF ! iflag_con
     95
     96    !
     97    !  print *,'JE inscav2'
     98    DO j = 1, klev
     99      DO i = 1, klon
     100        tr_seri(i, j, it) = aux_var1(i, j)
    53101      ENDDO
    54       ENDDO
    55 c     
    56       IF (lminmax) THEN
    57         CALL minmaxqfi(aux_var1,qmin,qmax,'avt inscav')
    58 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
    59       ENDIF
    60 c
    61 cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
    62 cnhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
    63 cnhl     .             his_dhlsc(1,it))
    64       CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
    65      .             prfl,psfl,zrho,zdz,t_seri,aux_var1,aux_var2)
    66 c
    67       IF (lminmax) THEN
    68         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide lsc')
    69 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
    70       ENDIF
    71 c
    72 c
    73 c-scheme for convective in-cloud scavenging
    74 c
    75 cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
    76 cnhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
    77 cnhl     .             his_dhcon1(1,it))
     102    ENDDO
     103    DO i = 1, klon
     104      his_dhlsc(i, it) = aux_var2(i)
     105      his_dhcon1(i, it) = aux_var3(i)
     106    ENDDO
    78107
    79 c      print *,'JE inscav0'
    80 c      IF (iflag_con.LT.3) THEN
    81 c
    82 c      print *,'JE inscav1'
    83 c      print *,'iflag_con',iflag_con
    84 c      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
    85 c     .             pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
    86 c
    87 cc
    88 c      IF (lminmax) THEN
    89 c        CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
    90 ccnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
    91 c
    92 c      ENDIF
    93 c
    94 c      ENDIF ! iflag_con
     108    !
     109  ENDDO !--boucle sur it
    95110
    96 c
    97 c      print *,'JE inscav2'
    98       DO j=1,klev
    99       DO i=1,klon
    100         tr_seri(i,j,it)=aux_var1(i,j)
    101       ENDDO
    102       ENDDO
    103       DO i=1,klon
    104         his_dhlsc(i,it)=aux_var2(i)
    105         his_dhcon1(i,it)=aux_var3(i)
    106       ENDDO
    107 
    108 c
    109       ENDDO !--boucle sur it
    110 
    111 c      print *,'JE inscav3'
    112       END
     111  ! print *,'JE inscav3'
     112END SUBROUTINE incloud_scav_lsc

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/inscav_spl.f90

    r5103 r5104  
    1       SUBROUTINE inscav_spl(pdtime,it,masse,henry,kk,qliq,
    2      .                   flxr,flxs,zrho,zdz,t,x,
    3      .                   his_dh)
    4       USE dimphy
    5       IMPLICIT NONE
    6 c=====================================================================
    7 c Objet : depot humide de traceurs
    8 c Date : mars 1998
    9 c Auteur: O. Boucher (LOA)
    10 c=====================================================================
    11 c
    12       INCLUDE "dimensions.h"
    13       INCLUDE "chem.h"
    14       INCLUDE "YOMCST.h"
    15       INCLUDE "YOECUMF.h"
    16 c
    17       INTEGER it
    18       REAL pdtime              ! pas de temps (s)
    19       REAL masse               ! molar mass (except for BC/OM/IF/DUST=Nav)
    20       REAL henry               ! constante de Henry en mol/l/atm
    21       REAL kk                  ! coefficient de dependence en T (K)
    22       REAL qliq                ! contenu en eau liquide dans le nuage (kg/kg)
    23 !      REAL flxr(klon,klev+1)   ! flux precipitant de pluie
    24 !      REAL flxs(klon,klev+1)   ! flux precipitant de neige
    25       REAL flxr(klon,klev)   ! flux precipitant de pluie   ! Titane
    26       REAL flxs(klon,klev)   ! flux precipitant de neige   ! Titane
    27       REAL flxr_aux(klon,klev+1)
    28       REAL flxs_aux(klon,klev+1)
    29       REAL zrho(klon,klev)
    30       REAL zdz(klon,klev)
    31       REAL t(klon,klev)
    32       REAL x(klon,klev)        ! q de traceur 
    33       REAL his_dh(klon)        ! tendance de traceur integre verticalement
    34 c
    35 c--variables locales     
    36       INTEGER i, k
    37 c
    38       REAL dx      ! tendance de traceur
    39       REAL f_a     !--rapport de la phase aqueuse a la phase gazeuse
    40       REAL beta    !--taux de conversion de l'eau en pluie
    41       REAL henry_t !--constante de Henry a T t  (mol/l/atm)
    42       REAL scav(klon,klev)    !--fraction aqueuse du constituant
    43       REAL K1, K2, ph, frac
    44       REAL frac_gas, frac_aer !-cste pour la reevaporation
    45       PARAMETER (ph=5., frac_gas=1.0, frac_aer=0.5)
    46 c---cste de dissolution pour le depot humide
    47       REAL frac_fine_scav,frac_coar_scav
    48 c---added by nhl
    49       REAL aux_cte
     1SUBROUTINE inscav_spl(pdtime, it, masse, henry, kk, qliq, &
     2        flxr, flxs, zrho, zdz, t, x, &
     3        his_dh)
     4  USE dimphy
     5  IMPLICIT NONE
     6  !=====================================================================
     7  ! Objet : depot humide de traceurs
     8  ! Date : mars 1998
     9  ! Auteur: O. Boucher (LOA)
     10  !=====================================================================
     11  !
     12  INCLUDE "dimensions.h"
     13  INCLUDE "chem.h"
     14  INCLUDE "YOMCST.h"
     15  INCLUDE "YOECUMF.h"
     16  !
     17  INTEGER :: it
     18  REAL :: pdtime              ! pas de temps (s)
     19  REAL :: masse               ! molar mass (except for BC/OM/IF/DUST=Nav)
     20  REAL :: henry               ! constante de Henry en mol/l/atm
     21  REAL :: kk                  ! coefficient de dependence en T (K)
     22  REAL :: qliq                ! contenu en eau liquide dans le nuage (kg/kg)
     23  ! REAL flxr(klon,klev+1)   ! flux precipitant de pluie
     24  ! REAL flxs(klon,klev+1)   ! flux precipitant de neige
     25  REAL :: flxr(klon, klev)   ! flux precipitant de pluie   ! Titane
     26  REAL :: flxs(klon, klev)   ! flux precipitant de neige   ! Titane
     27  REAL :: flxr_aux(klon, klev + 1)
     28  REAL :: flxs_aux(klon, klev + 1)
     29  REAL :: zrho(klon, klev)
     30  REAL :: zdz(klon, klev)
     31  REAL :: t(klon, klev)
     32  REAL :: x(klon, klev)        ! q de traceur
     33  REAL :: his_dh(klon)        ! tendance de traceur integre verticalement
     34  !
     35  !--variables locales
     36  INTEGER :: i, k
     37  !
     38  REAL :: dx      ! tendance de traceur
     39  REAL :: f_a     !--rapport de la phase aqueuse a la phase gazeuse
     40  REAL :: beta    !--taux de conversion de l'eau en pluie
     41  REAL :: henry_t !--constante de Henry a T t  (mol/l/atm)
     42  REAL :: scav(klon, klev)    !--fraction aqueuse du constituant
     43  REAL :: K1, K2, ph, frac
     44  REAL :: frac_gas, frac_aer !-cste pour la reevaporation
     45  PARAMETER (ph = 5., frac_gas = 1.0, frac_aer = 0.5)
     46  !---cste de dissolution pour le depot humide
     47  REAL :: frac_fine_scav, frac_coar_scav
     48  !---added by nhl
     49  REAL :: aux_cte
    5050
    51       PARAMETER (frac_fine_scav=0.7)
    52       PARAMETER (frac_coar_scav=0.7)
     51  PARAMETER (frac_fine_scav = 0.7)
     52  PARAMETER (frac_coar_scav = 0.7)
    5353
    54 c--101.325  m3/l x Pa/atm
    55 c--R        Pa.m3/mol/K
    56 c
    57 c------------------------------------------
    58 c
    59 cnhl      IF (it.EQ.2.OR.it.EQ.3) THEN !--aerosol  ! AS IT WAS FIRST
    60       IF (it==2.OR.it==3.OR.it==4) THEN !--aerosol
    61         frac=frac_aer
    62       ELSE                                                !--gas
    63         frac=frac_gas
     54  !--101.325  m3/l x Pa/atm
     55  !--R        Pa.m3/mol/K
     56  !
     57  !------------------------------------------
     58  !
     59  !nhl      IF (it.EQ.2.OR.it.EQ.3) THEN !--aerosol  ! AS IT WAS FIRST
     60  IF (it==2.OR.it==3.OR.it==4) THEN !--aerosol
     61    frac = frac_aer
     62  ELSE                                                !--gas
     63    frac = frac_gas
     64  ENDIF
     65  !
     66  IF (it==1) THEN
     67    DO k = 1, klev
     68      DO i = 1, klon
     69        henry_t = henry * exp(-kk * (1. / 298. - 1. / t(i, k)))    !--mol/l/atm
     70        K1 = 1.2e-2 * exp(-2010 * (1 / 298. - 1 / t(i, k)))
     71        K2 = 6.6e-8 * exp(-1510 * (1 / 298. - 1 / t(i, k)))
     72        henry_t = henry_t * (1 + K1 / 10.**(-ph) + K1 * K2 / (10.**(-ph))**2)
     73        f_a = henry_t / 101.325 * R * t(i, k) * qliq * zrho(i, k) / rho_water
     74        scav(i, k) = f_a / (1. + f_a)
     75      ENDDO
     76    ENDDO
     77  ELSEIF (it==2) THEN
     78    DO k = 1, klev
     79      DO i = 1, klon
     80        scav(i, k) = frac_fine_scav
     81      ENDDO
     82    ENDDO
     83  ELSEIF (it==3) THEN
     84    DO k = 1, klev
     85      DO i = 1, klon
     86        scav(i, k) = frac_coar_scav
     87      ENDDO
     88    ENDDO
     89  ELSEIF (it==4) THEN
     90    DO k = 1, klev
     91      DO i = 1, klon
     92        scav(i, k) = frac_coar_scav
     93      ENDDO
     94    ENDDO
     95  ELSE
     96    PRINT *, 'it non pris en compte'
     97    STOP
     98  ENDIF
     99  !
     100  ! NHL
     101  ! Auxiliary variables defined to deal with the fact that precipitation
     102  ! fluxes are defined on klev levels only.
     103  ! NHL
     104
     105  flxr_aux(:, klev + 1) = 0.0
     106  flxs_aux(:, klev + 1) = 0.0
     107  flxr_aux(:, 1:klev) = flxr(:, :)
     108  flxs_aux(:, 1:klev) = flxs(:, :)
     109  DO k = klev, 1, -1
     110    DO i = 1, klon
     111      !--scavenging
     112      beta = flxr_aux(i, k) - flxr_aux(i, k + 1) + flxs_aux(i, k) - flxs_aux(i, k + 1)
     113      beta = beta / zdz(i, k) / qliq / zrho(i, k)
     114      beta = MAX(0.0, beta)
     115      dx = x(i, k) * (exp(-scav(i, k) * beta * pdtime) - 1.)
     116      x(i, k) = x(i, k) + dx
     117      his_dh(i) = his_dh(i) - dx / RNAVO * &
     118              masse * 1.e3 * 1.e6 * zdz(i, k) / pdtime !--mgS/m2/s
     119      !--reevaporation
     120      beta = flxr_aux(i, k) - flxr_aux(i, k + 1) + flxs_aux(i, k) - flxs_aux(i, k + 1)
     121      IF (beta<0.) beta = beta / (flxr_aux(i, k + 1) + flxs_aux(i, k + 1))
     122      IF (flxr_aux(i, k) + flxs_aux(i, k)==0) THEN  !--reevaporation totale
     123        beta = MIN(MAX(0.0, -beta), 1.0)
     124      ELSE                          !--reevaporation non totale pour aerosols
     125        ! !print *,'FRAC USED IN INSCAV_SPL'
     126        beta = MIN(MAX(0.0, -beta) * frac, 1.0)
    64127      ENDIF
    65 c
    66       IF (it==1) THEN
    67       DO k=1, klev
    68       DO i=1, klon
    69         henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !--mol/l/atm
    70         K1=1.2e-2*exp(-2010*(1/298.-1/t(i,k)))
    71         K2=6.6e-8*exp(-1510*(1/298.-1/t(i,k)))
    72         henry_t=henry_t*(1 + K1/10.**(-ph) + K1*K2/(10.**(-ph))**2)
    73         f_a=henry_t/101.325*R*t(i,k)*qliq*zrho(i,k)/rho_water
    74         scav(i,k)=f_a/(1.+f_a)
    75       ENDDO
    76       ENDDO
    77       ELSEIF (it==2) THEN
    78       DO k=1, klev
    79       DO i=1, klon
    80         scav(i,k)=frac_fine_scav
    81       ENDDO
    82       ENDDO
    83       ELSEIF (it==3) THEN
    84       DO k=1, klev
    85       DO i=1, klon
    86         scav(i,k)=frac_coar_scav
    87       ENDDO
    88       ENDDO
    89       ELSEIF (it==4) THEN
    90       DO k=1, klev
    91       DO i=1, klon
    92         scav(i,k)=frac_coar_scav
    93       ENDDO
    94       ENDDO
    95       ELSE
    96         PRINT *,'it non pris en compte'
    97         STOP
    98       ENDIF
    99 c
    100 ! NHL
    101 ! Auxiliary variables defined to deal with the fact that precipitation
    102 ! fluxes are defined on klev levels only.
    103 ! NHL
    104 
    105       flxr_aux(:,klev+1)=0.0
    106       flxs_aux(:,klev+1)=0.0
    107       flxr_aux(:,1:klev)=flxr(:,:)
    108       flxs_aux(:,1:klev)=flxs(:,:)
    109       DO k=klev, 1, -1
    110       DO i=1, klon
    111 c--scavenging
    112         beta=flxr_aux(i,k)-flxr_aux(i,k+1)+flxs_aux(i,k)-flxs_aux(i,k+1)
    113         beta=beta/zdz(i,k)/qliq/zrho(i,k)
    114         beta=MAX(0.0,beta)
    115         dx=x(i,k)*(exp(-scav(i,k)*beta*pdtime)-1.)
    116         x(i,k)=x(i,k)+dx
    117         his_dh(i)=his_dh(i)-dx/RNAVO*
    118      .            masse*1.e3*1.e6*zdz(i,k)/pdtime !--mgS/m2/s
    119 c--reevaporation
    120         beta=flxr_aux(i,k)-flxr_aux(i,k+1)+flxs_aux(i,k)-flxs_aux(i,k+1)
    121         IF (beta<0.) beta=beta/(flxr_aux(i,k+1)+flxs_aux(i,k+1))
    122         IF (flxr_aux(i,k)+flxs_aux(i,k)==0) THEN  !--reevaporation totale
    123           beta=MIN(MAX(0.0,-beta),1.0)
    124         ELSE                          !--reevaporation non totale pour aerosols
    125           !print *,'FRAC USED IN INSCAV_SPL'
    126           beta=MIN(MAX(0.0,-beta)*frac,1.0)
    127         ENDIF
    128         dx=beta*his_dh(i)*RNAVO/masse/1.e3/1.e6/zdz(i,k)*pdtime !ORIG LINE
    129 ! funny line for TL/AD
    130 ! AD test works without (x) and for xd = dxd*1.e5 : 2.79051851638 times the 0.
    131 ! AD test does not work with the line : 754592404.083 times the 0.
    132 ! problem seems to be linked to the largest dx wrt x
    133 !       x(i, k) = x(i, k) + dx
    134 !        x(i, k) = x(i, k) + dx         ! THIS LINE WAS COMMENTED OUT ORIGINALY !nhl
    135         his_dh(i)=(1.-beta)*his_dh(i)
    136       ENDDO
    137       ENDDO
    138 c
    139       RETURN
    140       END
     128      dx = beta * his_dh(i) * RNAVO / masse / 1.e3 / 1.e6 / zdz(i, k) * pdtime !ORIG LINE
     129      ! funny line for TL/AD
     130      ! AD test works without (x) and for xd = dxd*1.e5 : 2.79051851638 times the 0.
     131      ! AD test does not work with the line : 754592404.083 times the 0.
     132      ! problem seems to be linked to the largest dx wrt x
     133      ! x(i, k) = x(i, k) + dx
     134      !  x(i, k) = x(i, k) + dx         ! THIS LINE WAS COMMENTED OUT ORIGINALY !nhl
     135      his_dh(i) = (1. - beta) * his_dh(i)
     136    ENDDO
     137  ENDDO
     138  !
     139  RETURN
     140END SUBROUTINE inscav_spl

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/minmaxqfi2.f90

    r5103 r5104  
    1       SUBROUTINE minmaxqfi2(zq,qmin,qmax,comment)
    2 c
    3       USE dimphy
    4       USE infotrac
    5       INCLUDE "dimensions.h"
     1SUBROUTINE minmaxqfi2(zq, qmin, qmax, comment)
     2  !
     3  USE dimphy
     4  USE infotrac
     5  INCLUDE "dimensions.h"
    66
    7 !      character*20 comment
    8       character*(*) comment
    9       real qmin,qmax
    10       real zq(klon,klev)
     7  ! character*20 comment
     8  character(len = *) :: comment
     9  real :: qmin, qmax
     10  real :: zq(klon, klev)
    1111
    12       integer ijmin, lmin, ijlmin
    13       integer ijmax, lmax, ijlmax
     12  integer :: ijmin, lmin, ijlmin
     13  integer :: ijmax, lmax, ijlmax
    1414
    15       integer ismin,ismax
     15  integer :: ismin, ismax
    1616
    17       ijlmin=ismin(klon*klev,zq,1)
    18       lmin=(ijlmin-1)/klon+1
    19       ijmin=ijlmin-(lmin-1)*klon
    20       zqmin=zq(ijmin,lmin)
     17  ijlmin = ismin(klon * klev, zq, 1)
     18  lmin = (ijlmin - 1) / klon + 1
     19  ijmin = ijlmin - (lmin - 1) * klon
     20  zqmin = zq(ijmin, lmin)
    2121
    22       ijlmax=ismax(klon*klev,zq,1)
    23       lmax=(ijlmax-1)/klon+1
    24       ijmax=ijlmax-(lmax-1)*klon
    25       zqmax=zq(ijmax,lmax)
    26  
    27       if(zqmin<qmin.or.zqmax>qmax)
    28      s     write(*,9999) comment,
    29      s     ijmin,lmin,zqmin,ijmax,lmax,zqmax
     22  ijlmax = ismax(klon * klev, zq, 1)
     23  lmax = (ijlmax - 1) / klon + 1
     24  ijmax = ijlmax - (lmax - 1) * klon
     25  zqmax = zq(ijmax, lmax)
    3026
    31       return
    32 9999  format(a20,2('  q(',i4,',',i2,')=',e12.5))
    33       end
     27  if(zqmin<qmin.or.zqmax>qmax) &
     28          write(*, 9999) comment, &
     29                  ijmin, lmin, zqmin, ijmax, lmax, zqmax
     30
     31  return
     32  9999   format(a20, 2('  q(', i4, ',', i2, ')=', e12.5))
     33end subroutine minmaxqfi2

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/minmaxsource.f90

    r5103 r5104  
    1       SUBROUTINE minmaxsource(zq,qmin,qmax,comment)
     1SUBROUTINE minmaxsource(zq, qmin, qmax, comment)
    22
    3       USE dimphy
    4       USE infotrac
     3  USE dimphy
     4  USE infotrac
    55
    6       INCLUDE "dimensions.h"
     6  INCLUDE "dimensions.h"
    77
    8 !      character*20 comment
    9       character*(*) comment
    10       real qmin,qmax
    11       real zq(klon,nbtr)
     8  ! character*20 comment
     9  character(len = *) :: comment
     10  real :: qmin, qmax
     11  real :: zq(klon, nbtr)
    1212
    13       integer ijmin, lmin, ijlmin
    14       integer ijmax, lmax, ijlmax
     13  integer :: ijmin, lmin, ijlmin
     14  integer :: ijmax, lmax, ijlmax
    1515
    16       integer ismin,ismax
     16  integer :: ismin, ismax
    1717
    18       ijlmin=ismin(klon*nbtr,zq,1)
    19       lmin=(ijlmin-1)/klon+1
    20       ijmin=ijlmin-(lmin-1)*klon
    21       zqmin=zq(ijmin,lmin)
     18  ijlmin = ismin(klon * nbtr, zq, 1)
     19  lmin = (ijlmin - 1) / klon + 1
     20  ijmin = ijlmin - (lmin - 1) * klon
     21  zqmin = zq(ijmin, lmin)
    2222
    23       ijlmax=ismax(klon*nbtr,zq,1)
    24       lmax=(ijlmax-1)/klon+1
    25       ijmax=ijlmax-(lmax-1)*klon
    26       zqmax=zq(ijmax,lmax)
     23  ijlmax = ismax(klon * nbtr, zq, 1)
     24  lmax = (ijlmax - 1) / klon + 1
     25  ijmax = ijlmax - (lmax - 1) * klon
     26  zqmax = zq(ijmax, lmax)
    2727
    28       if(zqmin<qmin.or.zqmax>qmax)
    29      s     write(*,9999) comment,
    30      s     ijmin,lmin,zqmin,ijmax,lmax,zqmax
     28  if(zqmin<qmin.or.zqmax>qmax) &
     29          write(*, 9999) comment, &
     30                  ijmin, lmin, zqmin, ijmax, lmax, zqmax
    3131
    32       return
    33 9999  format(a20,2('  q(',i4,',',i2,')=',e12.5))
    34       end
     32  return
     33  9999   format(a20, 2('  q(', i4, ',', i2, ')=', e12.5))
     34end subroutine minmaxsource

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/neutral.f90

    r5103 r5104  
    1 c***********************************************************************
    2         SUBROUTINE neutral(u10_mps,ustar_mps,obklen_m,
    3      +         u10n_mps )
    4 c-----------------------------------------------------------------------       
    5 c SUBROUTINE to compute u10 neutral wind speed
    6 c inputs
    7 c       u10_mps - wind speed at 10 m (m/s)
    8 c       ustar_mps - friction velocity (m/s)
    9 c       obklen_m - monin-obukhov length scale (m)
    10 c outputs
    11 c       u10n_mps - wind speed at 10 m under neutral conditions (m/s)
    12 c following code assumes reference height Z is 10m, consistent with use
    13 c of u10 and u10_neutral.  If not, code
    14 c should be changed so that constants of 50. and 160. in equations
    15 c below are changed to -5 * Z and -16 * Z respectively.
    16 c Reference:  G. L. Geernaert.  'Bulk parameterizations for the
    17 c wind stress and heat fluxes,' in Surface Waves and Fluxes, Vol. I,
    18 c Current Theory, Geernaert and W.J. Plant, editors, Kluwer Academic
    19 c Publishers, Boston, MA, 1990.
    20 c SUBROUTINE written Feb 2001 by eg chapman
    21 c adapted to LMD-ZT by E. Cosme 310801
    22 c Following Will Shaw (PNL, Seattle) the theory applied for flux
    23 c calculation with the scheme of Nightingale et al. (2000) does not
    24 c hold anymore when -1<obklen<20. In this case, u10n is set to 0,
    25 c so that the transfer velocity  computed in nightingale.F will also
    26 c be 0. The flux is then set to 0.
    27 c----------------------------------------------------------------------         
    28 c
    29       USE dimphy
    30       INCLUDE "dimensions.h"
    31 c
    32         real u10_mps(klon),ustar_mps(klon),obklen_m(klon)
    33         real u10n_mps(klon)
    34         real pi,von_karman
    35 c       parameter (pi = 3.141592653589793, von_karman = 0.4)   
    36 c pour etre coherent avec vk de bl_for_dms.F
    37         parameter (pi = 3.141592653589793, von_karman = 0.35)   
    38 c
    39         real phi, phi_inv, phi_inv_sq, f1, f2, f3, dum1, psi
    40         integer i
     1!***********************************************************************
     2SUBROUTINE neutral(u10_mps, ustar_mps, obklen_m, &
     3        u10n_mps)
     4  !-----------------------------------------------------------------------
     5  ! SUBROUTINE to compute u10 neutral wind speed
     6  ! inputs
     7  ! u10_mps - wind speed at 10 m (m/s)
     8  ! ustar_mps - friction velocity (m/s)
     9  ! obklen_m - monin-obukhov length scale (m)
     10  ! outputs
     11  ! u10n_mps - wind speed at 10 m under neutral conditions (m/s)
     12  ! following code assumes reference height Z is 10m, consistent with use
     13  ! of u10 and u10_neutral.  If not, code
     14  ! should be changed so that constants of 50. and 160. in equations
     15  ! below are changed to -5 * Z and -16 * Z respectively.
     16  ! Reference:  G. L. Geernaert.  'Bulk parameterizations for the
     17  ! wind stress and heat fluxes,' in Surface Waves and Fluxes, Vol. I,
     18  ! Current Theory, Geernaert and W.J. Plant, editors, Kluwer Academic
     19  ! Publishers, Boston, MA, 1990.
     20  ! SUBROUTINE written Feb 2001 by eg chapman
     21  ! adapted to LMD-ZT by E. Cosme 310801
     22  ! Following Will Shaw (PNL, Seattle) the theory applied for flux
     23  ! calculation with the scheme of Nightingale et al. (2000) does not
     24  ! hold anymore when -1<obklen<20. In this case, u10n is set to 0,
     25  ! so that the transfer velocity  computed in nightingale.F will also
     26  ! be 0. The flux is then set to 0.
     27  !----------------------------------------------------------------------
     28  !
     29  USE dimphy
     30  INCLUDE "dimensions.h"
     31  !
     32  real :: u10_mps(klon), ustar_mps(klon), obklen_m(klon)
     33  real :: u10n_mps(klon)
     34  real :: pi, von_karman
     35  ! parameter (pi = 3.141592653589793, von_karman = 0.4)
     36  ! pour etre coherent avec vk de bl_for_dms.F
     37  parameter (pi = 3.141592653589793, von_karman = 0.35)
     38  !
     39  real :: phi, phi_inv, phi_inv_sq, f1, f2, f3, dum1, psi
     40  integer :: i
    4141
     42  psi = 0.
     43  do i = 1, klon
    4244
    43         psi = 0.
    44         do i=1,klon
     45    if (u10_mps(i) < 0.) u10_mps(i) = 0.0
    4546
    46         if (u10_mps(i) < 0.) u10_mps(i) = 0.0
    47        
    48         if  (obklen_m(i) < 0.) then
    49                 phi = (1. - 160./obklen_m(i))**(-0.25)
    50                 phi_inv = 1./phi
    51                 phi_inv_sq = 1./phi * 1./phi
    52                 f1 = (1. + phi_inv) / 2.
    53                 f2 = (1. + phi_inv_sq)/2.
    54 c following to avoid numerical overruns. reCALL tan(90deg)=infinity
    55                 dum1 = min (1.e24, phi_inv)
    56                 f3 = atan(dum1)
    57                 psi = 2.*log(f1) + log(f2) - 2.*f3 + pi/2.   
    58         else if (obklen_m(i) > 0.) then
    59                 psi = -50. / obklen_m(i)
    60         end if
     47    if  (obklen_m(i) < 0.) then
     48      phi = (1. - 160. / obklen_m(i))**(-0.25)
     49      phi_inv = 1. / phi
     50      phi_inv_sq = 1. / phi * 1. / phi
     51      f1 = (1. + phi_inv) / 2.
     52      f2 = (1. + phi_inv_sq) / 2.
     53      ! following to avoid numerical overruns. reCALL tan(90deg)=infinity
     54      dum1 = min (1.e24, phi_inv)
     55      f3 = atan(dum1)
     56      psi = 2. * log(f1) + log(f2) - 2. * f3 + pi / 2.
     57    else if (obklen_m(i) > 0.) then
     58      psi = -50. / obklen_m(i)
     59    end if
    6160
    62         u10n_mps(i) = u10_mps(i) + (ustar_mps(i) * psi /von_karman )
    63 c u10n set to 0. if -1 < obklen < 20
    64         if ((obklen_m(i)>-1.).and.(obklen_m(i)<20.)) then
    65             u10n_mps(i) = 0.
    66         endif
    67         if (u10n_mps(i) < 0.) u10n_mps(i) = 0.0
     61    u10n_mps(i) = u10_mps(i) + (ustar_mps(i) * psi / von_karman)
     62    ! u10n set to 0. if -1 < obklen < 20
     63    if ((obklen_m(i)>-1.).and.(obklen_m(i)<20.)) then
     64      u10n_mps(i) = 0.
     65    endif
     66    if (u10n_mps(i) < 0.) u10n_mps(i) = 0.0
    6867
    69         enddo
    70         return
    71         end
    72 c***********************************************************************
     68  enddo
     69  return
     70end subroutine neutral
     71!***********************************************************************

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/nightingale.f90

    r5103 r5104  
    1       SUBROUTINE nightingale(u, v, u_10m, v_10m, paprs, pplay,
    2      .                       cdragh, cdragm, t, q, ftsol, tsol,
    3      .                       pctsrf, lmt_dmsconc, lmt_dms)
    4 c
    5       USE dimphy
    6       USE indice_sol_mod
    7       IMPLICIT NONE
    8 c
    9       INCLUDE "dimensions.h"
    10       INCLUDE "YOMCST.h"
    11 c
    12       REAL u(klon,klev), v(klon,klev)
    13       REAL u_10m(klon), v_10m(klon)
    14       REAL ftsol(klon,nbsrf)
    15       REAL tsol(klon)
    16       REAL paprs(klon,klev+1), pplay(klon,klev)
    17       REAL t(klon,klev)
    18       REAL q(klon,klev)
    19       REAL cdragh(klon), cdragm(klon)
    20       REAL pctsrf(klon,nbsrf)
    21       REAL lmt_dmsconc(klon)  ! concentration oceanique DMS
    22       REAL lmt_dms(klon)      ! flux de DMS
    23 c
    24       REAL ustar(klon), obklen(klon)
    25       REAL u10(klon), u10n(klon)
    26       REAL tvelocity, schmidt_corr
    27       REAL t1, t2, t3, t4, viscosity_kin, diffusivity, schmidt
    28       INTEGER i
    29 c
    30       CALL bl_for_dms(u, v, paprs, pplay, cdragh, cdragm,
    31      .                t, q, tsol, ustar, obklen)
    32 c
    33       DO i=1,klon
    34         u10(i)=SQRT(u_10m(i)**2+v_10m(i)**2)
    35       ENDDO
    36 c
    37       CALL neutral(u10, ustar, obklen, u10n)
    38 c
    39       DO i=1,klon
    40 c
    41 c       tvelocity - transfer velocity, also known as kw (cm/s)
    42 c       schmidt_corr - Schmidt number correction factor (dimensionless)
    43 c Reference:  Nightingale, P.D., G. Malin, C. S. Law, J. J. Watson, P.S. Liss
    44 c  M. I. Liddicoat, J. Boutin, R.C. Upstill-Goddard. 'In situ evaluation
    45 c  of air-sea gas exchange parameterizations using conservative and
    46 c  volatile tracers.'  Glob. Biogeochem. Cycles, 14:373-387, 2000.
    47 c compute transfer velocity using u10neutral     
    48 c
    49       tvelocity = 0.222*u10n(i)*u10n(i) + 0.333*u10n(i)
    50 c
    51 c above expression gives tvelocity in cm/hr. convert to cm/s. 1hr =3600 sec
     1SUBROUTINE nightingale(u, v, u_10m, v_10m, paprs, pplay, &
     2        cdragh, cdragm, t, q, ftsol, tsol, &
     3        pctsrf, lmt_dmsconc, lmt_dms)
     4  !
     5  USE dimphy
     6  USE indice_sol_mod
     7  IMPLICIT NONE
     8  !
     9  INCLUDE "dimensions.h"
     10  INCLUDE "YOMCST.h"
     11  !
     12  REAL :: u(klon, klev), v(klon, klev)
     13  REAL :: u_10m(klon), v_10m(klon)
     14  REAL :: ftsol(klon, nbsrf)
     15  REAL :: tsol(klon)
     16  REAL :: paprs(klon, klev + 1), pplay(klon, klev)
     17  REAL :: t(klon, klev)
     18  REAL :: q(klon, klev)
     19  REAL :: cdragh(klon), cdragm(klon)
     20  REAL :: pctsrf(klon, nbsrf)
     21  REAL :: lmt_dmsconc(klon)  ! concentration oceanique DMS
     22  REAL :: lmt_dms(klon)      ! flux de DMS
     23  !
     24  REAL :: ustar(klon), obklen(klon)
     25  REAL :: u10(klon), u10n(klon)
     26  REAL :: tvelocity, schmidt_corr
     27  REAL :: t1, t2, t3, t4, viscosity_kin, diffusivity, schmidt
     28  INTEGER :: i
     29  !
     30  CALL bl_for_dms(u, v, paprs, pplay, cdragh, cdragm, &
     31          t, q, tsol, ustar, obklen)
     32  !
     33  DO i = 1, klon
     34    u10(i) = SQRT(u_10m(i)**2 + v_10m(i)**2)
     35  ENDDO
     36  !
     37  CALL neutral(u10, ustar, obklen, u10n)
     38  !
     39  DO i = 1, klon
     40    !
     41    ! tvelocity - transfer velocity, also known as kw (cm/s)
     42    ! schmidt_corr - Schmidt number correction factor (dimensionless)
     43    ! Reference:  Nightingale, P.D., G. Malin, C. S. Law, J. J. Watson, P.S. Liss
     44    !  M. I. Liddicoat, J. Boutin, R.C. Upstill-Goddard. 'In situ evaluation
     45    !  of air-sea gas exchange parameterizations using conservative and
     46    !  volatile tracers.'  Glob. Biogeochem. Cycles, 14:373-387, 2000.
     47    ! compute transfer velocity using u10neutral
     48    !
     49    tvelocity = 0.222 * u10n(i) * u10n(i) + 0.333 * u10n(i)
     50    !
     51    ! above expression gives tvelocity in cm/hr. convert to cm/s. 1hr =3600 sec
    5252
    53       tvelocity = tvelocity / 3600.     
     53    tvelocity = tvelocity / 3600.
    5454
    55 c compute the correction factor, which for Nightingale parameterization is
    56 c based on how different the schmidt number is from 600.   
    57 c correction factor based on temperature in Kelvin. good
    58 c only for t<=30 deg C.  for temperatures above that, set correction factor
    59 c equal to value at 30 deg C.
     55    ! compute the correction factor, which for Nightingale parameterization is
     56    ! based on how different the schmidt number is from 600.
     57    ! correction factor based on temperature in Kelvin. good
     58    ! only for t<=30 deg C.  for temperatures above that, set correction factor
     59    ! equal to value at 30 deg C.
    6060
    61       IF (ftsol(i,is_oce) <= 303.15) THEN
    62          t1 = ftsol(i,is_oce)
    63       ELSE
    64          t1 = 303.15
    65       ENDIF       
     61    IF (ftsol(i, is_oce) <= 303.15) THEN
     62      t1 = ftsol(i, is_oce)
     63    ELSE
     64      t1 = 303.15
     65    ENDIF
    6666
    67       t2 = t1 * t1
    68       t3 = t2 * t1
    69       t4 = t3 * t1
    70       viscosity_kin = 3.0363e-9*t4 - 3.655198e-6*t3 + 1.65333e-3*t2
    71      +      - 3.332083e-1*t1 + 25.26819
    72       diffusivity = 0.01922 * exp(-2177.1/t1)
    73       schmidt = viscosity_kin / diffusivity
    74       schmidt_corr = (schmidt/600.)**(-.5)               
    75 c
    76       lmt_dms(i) = tvelocity  *  pctsrf(i,is_oce)
    77      .        * lmt_dmsconc(i)/1.0e12 * schmidt_corr * RNAVO
    78 c
    79       IF (lmt_dmsconc(i)<=1.e-20) lmt_dms(i)=0.0
    80 c
    81       ENDDO
    82 c
    83       END
     67    t2 = t1 * t1
     68    t3 = t2 * t1
     69    t4 = t3 * t1
     70    viscosity_kin = 3.0363e-9 * t4 - 3.655198e-6 * t3 + 1.65333e-3 * t2 &
     71            - 3.332083e-1 * t1 + 25.26819
     72    diffusivity = 0.01922 * exp(-2177.1 / t1)
     73    schmidt = viscosity_kin / diffusivity
     74    schmidt_corr = (schmidt / 600.)**(-.5)
     75    !
     76    lmt_dms(i) = tvelocity * pctsrf(i, is_oce) &
     77            * lmt_dmsconc(i) / 1.0e12 * schmidt_corr * RNAVO
     78    !
     79    IF (lmt_dmsconc(i)<=1.e-20) lmt_dms(i) = 0.0
     80    !
     81  ENDDO
     82  !
     83END SUBROUTINE nightingale

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/precuremission.f90

    r5103 r5104  
    1 C Subroutine that calculates the emission of aerosols precursors
    2       SUBROUTINE precuremission(ftsol,u10m_ec,v10m_ec,
    3      .                          pctsrf,u_seri,v_seri,paprs,pplay,cdragh,
    4      .                          cdragm,t_seri,q_seri,tsol,fracso2emis,
    5      .                          frach2sofso2,bateau,zdz,zalt,
    6      .                          kminbc,kmaxbc,pdtphys,scale_param_bb,
    7      .                          scale_param_ind,iregion_ind,iregion_bb,
    8      .                          nbreg_ind, nbreg_bb,
    9      .                          lmt_so2ff_l,lmt_so2ff_h,lmt_so2nff,
    10      .                          lmt_so2ba,lmt_so2bb_l,lmt_so2bb_h,
    11      .                          lmt_so2volc_cont,lmt_altvolc_cont,
    12      .                          lmt_so2volc_expl,lmt_altvolc_expl,
    13      .                          lmt_dmsbio,lmt_h2sbio, lmt_dmsconc,
    14      .                          lmt_dms,id_prec,id_fine,
    15      .                                 flux_sparam_ind,flux_sparam_bb,
    16      .                                 source_tr,flux_tr,tr_seri)
    17 
    18       USE dimphy
    19       USE indice_sol_mod
    20       USE infotrac
    21 !      USE phytracr_spl_mod, ONLY: nbreg_dust, nbreg_ind, nbreg_bb
    22       IMPLICIT NONE
    23 
    24       INCLUDE "dimensions.h"
    25       INCLUDE "chem.h"
    26       INCLUDE "chem_spla.h"
    27       INCLUDE "YOMCST.h"
    28       INCLUDE "paramet.h"
    29 
    30 c============================= INPUT ===================================
    31       INTEGER kminbc, kmaxbc
    32       REAL ftsol(klon,nbsrf)  ! temperature du sol par type
    33       REAL tsol(klon)         ! temperature du sol moyenne
    34       REAL t_seri(klon,klev)  ! temperature
    35       REAL u_seri(klon,klev)  ! vent
    36       REAL v_seri(klon,klev)  ! vent
    37       REAL q_seri(klon,klev)  ! vapeur d eau kg/kg
    38       REAL u10m_ec(klon), v10m_ec(klon)  ! vent a 10 metres
    39       REAL pctsrf(klon,nbsrf)
    40       REAL pdtphys  ! pas d'integration pour la physique (seconde)
    41       REAL paprs(klon,klev+1)  ! pression pour chaque inter-couche (en Pa)
    42       REAL pplay(klon,klev)  ! pression pour le mileu de chaque couche (en Pa)
    43       REAL cdragh(klon), cdragm(klon)     
    44       REAL fracso2emis        !--fraction so2 emis en so2
    45       REAL frach2sofso2       !--fraction h2s from so2
    46       REAL zdz(klon,klev)
    47       LOGICAL edgar, bateau
    48       INTEGER id_prec,id_fine
    49 c
    50 c------------------------- Scaling Parameters --------------------------
    51 c
    52       INTEGER nbreg_ind, nbreg_bb
    53       INTEGER iregion_ind(klon)  !Defines regions for SO2, BC & OM
    54       INTEGER iregion_bb(klon)  !Defines regions for SO2, BC & OM
    55       REAL scale_param_bb(nbreg_bb)  !Scaling parameter for biomas burning
    56       REAL scale_param_ind(nbreg_ind) !Scaling parameter for industrial emissions
    57 c
    58 c============================= OUTPUT ==================================
    59 c
    60       REAL source_tr(klon,nbtr)
    61       REAL flux_tr(klon,nbtr)
    62       REAL tr_seri(klon,klev,nbtr) ! traceur
    63       REAL flux_sparam_ind(klon), flux_sparam_bb(klon)
    64 c========================= LOCAL VARIABLES =============================
    65       INTEGER i, k, kkk_cont(klon), kkk_expl(klon)
    66       REAL zalt(klon,klev), zaltmid(klon,klev)
    67       REAL zzdz
    68 c------------------------- SULFUR emissions ----------------------------
    69       REAL lmt_so2volc_cont(klon)  ! emissions so2 volcan (continuous)
    70       REAL lmt_altvolc_cont(klon)  ! altitude  so2 volcan (continuous)
    71       REAL lmt_so2volc_expl(klon)  ! emissions so2 volcan (explosive)
    72       REAL lmt_altvolc_expl(klon)  ! altitude  so2 volcan (explosive)
    73       REAL lmt_so2ff_l(klon)       ! emissions so2 fossil fuel (low)
    74       REAL lmt_so2ff_h(klon)       ! emissions so2 fossil fuel (high)
    75       REAL lmt_so2nff(klon)        ! emissions so2 non-fossil fuel
    76       REAL lmt_so2bb_l(klon)       ! emissions de so2 biomass burning (low)
    77       REAL lmt_so2bb_h(klon)       ! emissions de so2 biomass burning (high)
    78       REAL lmt_so2ba(klon)         ! emissions de so2 bateau
    79       REAL lmt_dms(klon)           ! emissions de dms
    80       REAL lmt_dmsconc(klon)       ! concentration de dms oceanique
    81       REAL lmt_dmsbio(klon)        ! emissions de dms bio
    82       REAL lmt_h2sbio(klon)        ! emissions de h2s bio
    83                        
    84       EXTERNAL condsurfs, liss, nightingale
    85 c=========================================================================
    86 c Modifications introduced by NHL
    87 c -Variables to save fluxes were introduced
    88 c -lmt_so2ba was multiplied by fracso2emis in line 117
    89 c -scale_param_bb was introduced in line 105
    90 c The last two modifications were errors existing in the original version
    91 c=========================================================================
    92 c=========================================================================
    93 c                        LOW LEVEL EMISSIONS
    94 c=========================================================================
    95                        
    96          CALL nightingale(u_seri, v_seri, u10m_ec, v10m_ec, paprs,
    97      .                 pplay, cdragh, cdragm, t_seri, q_seri, ftsol,
    98      .                 tsol, pctsrf, lmt_dmsconc, lmt_dms)
    99 
    100       IF (.not.bateau) THEN
    101         DO i=1, klon     
    102           lmt_so2ba(i)=0.0
    103         ENDDO
    104       ENDIF
    105 
    106       DO i=1, klon
    107          IF (iregion_ind(i)>0) THEN
    108        IF(id_prec>0) source_tr(i,id_prec)=source_tr(i,id_prec)
    109      .             + fracso2emis
    110      .             *scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)*1.e4
    111      .             +scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)*1.e4
    112      .                   *frach2sofso2            ! molec/m2/s
    113 c
    114       IF(id_fine>0) source_tr(i,id_fine)=
    115      .                source_tr(i,id_fine)+(1-fracso2emis)
    116      .                *scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)
    117      .                *1.e4*masse_ammsulfate/RNAVO  ! g/m2/s
    118 c
    119        IF(id_prec>0)   flux_tr(i,id_prec)=flux_tr(i,id_prec) + (
    120      .               scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
    121      .                lmt_so2ff_h(i))
    122      .                *frach2sofso2
    123      .               +scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
    124      .                lmt_so2ff_h(i))
    125      .                *fracso2emis
    126      .                )*1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
    127 c
    128       IF(id_fine>0)  flux_tr(i,id_fine)=
    129      . flux_tr(i,id_fine)+(1-fracso2emis)
    130      .               *scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
    131      .                lmt_so2ff_h(i))
    132      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
    133 c
    134       flux_sparam_ind(i)=flux_sparam_ind(i)+ (1-fracso2emis)
    135      .               *scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
    136      .                lmt_so2ff_h(i))
    137      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
    138          ENDIF
    139          IF (iregion_bb(i)>0) THEN
    140       IF(id_prec>0) source_tr(i,id_prec)=
    141      .                  source_tr(i,id_prec) + fracso2emis
    142      .                 *scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)
    143      .                   *(1.-pctsrf(i,is_oce))*1.e4
    144 c
    145       IF(id_fine>0)     source_tr(i,id_fine)=
    146      .                   source_tr(i,id_fine)+(1-fracso2emis)
    147      .                  *scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)*
    148      .                   (1.-pctsrf(i,is_oce))*1.e4*
    149      .                   masse_ammsulfate/RNAVO  ! g/m2/s
    150 c
    151       IF(id_prec>0)     flux_tr(i,id_prec)=flux_tr(i,id_prec) +
    152      .               (scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)
    153      .                 +scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i))
    154      .                      * (1.-pctsrf(i,is_oce))*fracso2emis
    155      .                 *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
    156 c
    157       IF(id_fine>0) flux_tr(i,id_fine)=
    158      .                flux_tr(i,id_fine)+(1-fracso2emis)
    159      .               *(scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)
    160      .                +scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i))
    161      .                *(1.-pctsrf(i,is_oce))
    162      .                *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
    163 c
    164            flux_sparam_bb(i)=
    165      .                scale_param_bb(iregion_bb(i))*(lmt_so2bb_l(i)+
    166      .                                        lmt_so2bb_h(i))
    167      .                      * (1.-pctsrf(i,is_oce))*fracso2emis
    168      .              *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
    169            flux_sparam_bb(i)= flux_sparam_bb(i) + (1-fracso2emis) *
    170      .               (scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)+
    171      .                scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i))
    172      .                *(1.-pctsrf(i,is_oce))
    173      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
    174          ENDIF
    175       IF(id_prec>0)   source_tr(i,id_prec)=source_tr(i,id_prec)
    176      .                 + fracso2emis
    177      .                 *(lmt_so2ba(i)+lmt_so2nff(i))*1.e4
    178      .                 +(lmt_h2sbio(i)
    179      .                   +lmt_dms(i)+lmt_dmsbio(i))*1.e4            ! molec/m2/s
    180 c
    181       IF(id_fine>0)   source_tr(i,id_fine)=source_tr(i,id_fine)
    182      .                +(1-fracso2emis)
    183      .                *(lmt_so2ba(i)+lmt_so2nff(i))*1.e4*
    184      .                   masse_ammsulfate/RNAVO  ! g/m2/s
    185 c
    186       IF(id_prec>0)   flux_tr(i,id_prec)=flux_tr(i,id_prec)
    187      .               + (lmt_h2sbio(i)
    188      .               +lmt_so2volc_cont(i)+lmt_so2volc_expl(i)
    189      .                 +(lmt_so2ba(i)+lmt_so2nff(i))*fracso2emis
    190      .                 +lmt_dms(i)+lmt_dmsbio(i) )
    191      .              *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
    192 c
    193       IF(id_fine>0)   flux_tr(i,id_fine)=flux_tr(i,id_fine)
    194      .               +(1-fracso2emis)
    195      .               *(lmt_so2ba(i) + lmt_so2nff(i))
    196      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
    197 c
    198          flux_sparam_ind(i)=flux_sparam_ind(i)+ (1-fracso2emis)
    199      .               *lmt_so2nff(i)
    200      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
    201 c
    202       ENDDO
    203 
    204 c========================================================================
    205 c                        HIGH LEVEL EMISSIONS
    206 c========================================================================
    207 c  Source de SO2 volcaniques
    208       DO i = 1, klon
    209         kkk_cont(i)=1
    210         kkk_expl(i)=1
    211       ENDDO
    212       DO k=1, klev-1
    213       DO i = 1, klon
    214         zaltmid(i,k)=zalt(i,k)+zdz(i,k)/2.
    215         IF (zalt(i,k+1)<lmt_altvolc_cont(i)) kkk_cont(i)=k+1
    216         IF (zalt(i,k+1)<lmt_altvolc_expl(i)) kkk_expl(i)=k+1
    217       ENDDO
    218       ENDDO
    219       IF(id_prec>0) THEN
    220       DO i = 1, klon
    221         tr_seri(i,kkk_cont(i),id_prec)=tr_seri(i,kkk_cont(i),id_prec) +
    222      .               lmt_so2volc_cont(i)/zdz(i,kkk_cont(i))/100.*pdtphys
    223         tr_seri(i,kkk_expl(i),id_prec)=tr_seri(i,kkk_expl(i),id_prec) +
    224      .               lmt_so2volc_expl(i)/zdz(i,kkk_expl(i))/100.*pdtphys
    225       ENDDO
    226       ENDIF                                           
    227 c  Sources hautes de SO2     
    228      
    229 c
    230 c--only GEIA SO2 emissions has high emissions
    231 c--unit: molec/cm2/s divided by layer height (in cm) multiplied by timestep
    232 c
    233       k=2                             !introducing emissions in level 2
    234       DO i = 1, klon
    235 c
    236          IF (iregion_bb(i)>0) THEN
    237       IF(id_prec>0)   tr_seri(i,k,id_prec)=
    238      .              tr_seri(i,k,id_prec) + fracso2emis
    239      .              *scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)
    240      .              /zdz(i,k)/100.*pdtphys
    241 c
    242       IF(id_fine>0)     tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)
    243      .              + (1.-fracso2emis)
    244      .              *scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)
    245      .              *masse_ammsulfate/RNAVO/zdz(i,k)/100.*pdtphys   !g/cm3
    246          ENDIF
    247          IF (iregion_ind(i)>0) THEN
    248        IF(id_prec>0)  tr_seri(i,k,id_prec)=
    249      .              tr_seri(i,k,id_prec) + (fracso2emis
    250      .              *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i)
    251      .              + frach2sofso2
    252      .              *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i))
    253      .              /zdz(i,k)/100.*pdtphys
    254 c
    255        IF(id_fine>0)    tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)
    256      .               + (1.-fracso2emis)
    257      .              *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i)
    258      .              *masse_ammsulfate/RNAVO/zdz(i,k)/100.*pdtphys   !g/cm3
    259          ENDIF
    260 c
    261       ENDDO
    262 
    263       END
     1! Subroutine that calculates the emission of aerosols precursors
     2SUBROUTINE precuremission(ftsol, u10m_ec, v10m_ec, &
     3        pctsrf, u_seri, v_seri, paprs, pplay, cdragh, &
     4        cdragm, t_seri, q_seri, tsol, fracso2emis, &
     5        frach2sofso2, bateau, zdz, zalt, &
     6        kminbc, kmaxbc, pdtphys, scale_param_bb, &
     7        scale_param_ind, iregion_ind, iregion_bb, &
     8        nbreg_ind, nbreg_bb, &
     9        lmt_so2ff_l, lmt_so2ff_h, lmt_so2nff, &
     10        lmt_so2ba, lmt_so2bb_l, lmt_so2bb_h, &
     11        lmt_so2volc_cont, lmt_altvolc_cont, &
     12        lmt_so2volc_expl, lmt_altvolc_expl, &
     13        lmt_dmsbio, lmt_h2sbio, lmt_dmsconc, &
     14        lmt_dms, id_prec, id_fine, &
     15        flux_sparam_ind, flux_sparam_bb, &
     16        source_tr, flux_tr, tr_seri)
     17
     18  USE dimphy
     19  USE indice_sol_mod
     20  USE infotrac
     21  ! USE phytracr_spl_mod, ONLY: nbreg_dust, nbreg_ind, nbreg_bb
     22  IMPLICIT NONE
     23
     24  INCLUDE "dimensions.h"
     25  INCLUDE "chem.h"
     26  INCLUDE "chem_spla.h"
     27  INCLUDE "YOMCST.h"
     28  INCLUDE "paramet.h"
     29
     30  !============================= INPUT ===================================
     31  INTEGER :: kminbc, kmaxbc
     32  REAL :: ftsol(klon, nbsrf)  ! temperature du sol par type
     33  REAL :: tsol(klon)         ! temperature du sol moyenne
     34  REAL :: t_seri(klon, klev)  ! temperature
     35  REAL :: u_seri(klon, klev)  ! vent
     36  REAL :: v_seri(klon, klev)  ! vent
     37  REAL :: q_seri(klon, klev)  ! vapeur d eau kg/kg
     38  REAL :: u10m_ec(klon), v10m_ec(klon)  ! vent a 10 metres
     39  REAL :: pctsrf(klon, nbsrf)
     40  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     41  REAL :: paprs(klon, klev + 1)  ! pression pour chaque inter-couche (en Pa)
     42  REAL :: pplay(klon, klev)  ! pression pour le mileu de chaque couche (en Pa)
     43  REAL :: cdragh(klon), cdragm(klon)
     44  REAL :: fracso2emis        !--fraction so2 emis en so2
     45  REAL :: frach2sofso2       !--fraction h2s from so2
     46  REAL :: zdz(klon, klev)
     47  LOGICAL :: edgar, bateau
     48  INTEGER :: id_prec, id_fine
     49  !
     50  !------------------------- Scaling Parameters --------------------------
     51  !
     52  INTEGER :: nbreg_ind, nbreg_bb
     53  INTEGER :: iregion_ind(klon)  !Defines regions for SO2, BC & OM
     54  INTEGER :: iregion_bb(klon)  !Defines regions for SO2, BC & OM
     55  REAL :: scale_param_bb(nbreg_bb)  !Scaling parameter for biomas burning
     56  REAL :: scale_param_ind(nbreg_ind) !Scaling parameter for industrial emissions
     57  !
     58  !============================= OUTPUT ==================================
     59  !
     60  REAL :: source_tr(klon, nbtr)
     61  REAL :: flux_tr(klon, nbtr)
     62  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     63  REAL :: flux_sparam_ind(klon), flux_sparam_bb(klon)
     64  !========================= LOCAL VARIABLES =============================
     65  INTEGER :: i, k, kkk_cont(klon), kkk_expl(klon)
     66  REAL :: zalt(klon, klev), zaltmid(klon, klev)
     67  REAL :: zzdz
     68  !------------------------- SULFUR emissions ----------------------------
     69  REAL :: lmt_so2volc_cont(klon)  ! emissions so2 volcan (continuous)
     70  REAL :: lmt_altvolc_cont(klon)  ! altitude  so2 volcan (continuous)
     71  REAL :: lmt_so2volc_expl(klon)  ! emissions so2 volcan (explosive)
     72  REAL :: lmt_altvolc_expl(klon)  ! altitude  so2 volcan (explosive)
     73  REAL :: lmt_so2ff_l(klon)       ! emissions so2 fossil fuel (low)
     74  REAL :: lmt_so2ff_h(klon)       ! emissions so2 fossil fuel (high)
     75  REAL :: lmt_so2nff(klon)        ! emissions so2 non-fossil fuel
     76  REAL :: lmt_so2bb_l(klon)       ! emissions de so2 biomass burning (low)
     77  REAL :: lmt_so2bb_h(klon)       ! emissions de so2 biomass burning (high)
     78  REAL :: lmt_so2ba(klon)         ! emissions de so2 bateau
     79  REAL :: lmt_dms(klon)           ! emissions de dms
     80  REAL :: lmt_dmsconc(klon)       ! concentration de dms oceanique
     81  REAL :: lmt_dmsbio(klon)        ! emissions de dms bio
     82  REAL :: lmt_h2sbio(klon)        ! emissions de h2s bio
     83
     84  EXTERNAL condsurfs, liss, nightingale
     85  !=========================================================================
     86  ! Modifications introduced by NHL
     87  ! -Variables to save fluxes were introduced
     88  ! -lmt_so2ba was multiplied by fracso2emis in line 117
     89  ! -scale_param_bb was introduced in line 105
     90  ! The last two modifications were errors existing in the original version
     91  !=========================================================================
     92  !=========================================================================
     93  ! LOW LEVEL EMISSIONS
     94  !=========================================================================
     95
     96  CALL nightingale(u_seri, v_seri, u10m_ec, v10m_ec, paprs, &
     97          pplay, cdragh, cdragm, t_seri, q_seri, ftsol, &
     98          tsol, pctsrf, lmt_dmsconc, lmt_dms)
     99
     100  IF (.not.bateau) THEN
     101    DO i = 1, klon
     102      lmt_so2ba(i) = 0.0
     103    ENDDO
     104  ENDIF
     105
     106  DO i = 1, klon
     107    IF (iregion_ind(i)>0) THEN
     108      IF(id_prec>0) source_tr(i, id_prec) = source_tr(i, id_prec) &
     109              + fracso2emis &
     110                      * scale_param_ind(iregion_ind(i)) * lmt_so2ff_l(i) * 1.e4 &
     111              + scale_param_ind(iregion_ind(i)) * lmt_so2ff_l(i) * 1.e4 &
     112                      * frach2sofso2            ! molec/m2/s
     113      !
     114      IF(id_fine>0) source_tr(i, id_fine) = &
     115              source_tr(i, id_fine) + (1 - fracso2emis) &
     116                      * scale_param_ind(iregion_ind(i)) * lmt_so2ff_l(i) &
     117                      * 1.e4 * masse_ammsulfate / RNAVO  ! g/m2/s
     118      !
     119      IF(id_prec>0)   flux_tr(i, id_prec) = flux_tr(i, id_prec) + (&
     120              scale_param_ind(iregion_ind(i)) * (lmt_so2ff_l(i) + &
     121                      lmt_so2ff_h(i)) &
     122                      * frach2sofso2 &
     123                      + scale_param_ind(iregion_ind(i)) * (lmt_so2ff_l(i) + &
     124                      lmt_so2ff_h(i)) &
     125                      * fracso2emis &
     126              ) * 1.e4 / RNAVO * masse_s * 1.e3          ! mgS/m2/s
     127      !
     128      IF(id_fine>0)  flux_tr(i, id_fine) = &
     129              flux_tr(i, id_fine) + (1 - fracso2emis) &
     130                      * scale_param_ind(iregion_ind(i)) * (lmt_so2ff_l(i) + &
     131                      lmt_so2ff_h(i)) &
     132                      * 1.e4 / RNAVO * masse_ammsulfate * 1.e3    ! mgS/m2/s
     133      !
     134      flux_sparam_ind(i) = flux_sparam_ind(i) + (1 - fracso2emis) &
     135              * scale_param_ind(iregion_ind(i)) * (lmt_so2ff_l(i) + &
     136              lmt_so2ff_h(i)) &
     137              * 1.e4 / RNAVO * masse_ammsulfate * 1.e3    ! mgS/m2/s
     138    ENDIF
     139    IF (iregion_bb(i)>0) THEN
     140      IF(id_prec>0) source_tr(i, id_prec) = &
     141              source_tr(i, id_prec) + fracso2emis &
     142                      * scale_param_bb(iregion_bb(i)) * lmt_so2bb_l(i) &
     143                      * (1. - pctsrf(i, is_oce)) * 1.e4
     144      !
     145      IF(id_fine>0)     source_tr(i, id_fine) = &
     146              source_tr(i, id_fine) + (1 - fracso2emis) &
     147                      * scale_param_bb(iregion_bb(i)) * lmt_so2bb_l(i) * &
     148                      (1. - pctsrf(i, is_oce)) * 1.e4 * &
     149                      masse_ammsulfate / RNAVO  ! g/m2/s
     150      !
     151      IF(id_prec>0)     flux_tr(i, id_prec) = flux_tr(i, id_prec) + &
     152              (scale_param_bb(iregion_bb(i)) * lmt_so2bb_l(i) &
     153                      + scale_param_bb(iregion_bb(i)) * lmt_so2bb_h(i)) &
     154                      * (1. - pctsrf(i, is_oce)) * fracso2emis &
     155                      * 1.e4 / RNAVO * masse_s * 1.e3          ! mgS/m2/s
     156      !
     157      IF(id_fine>0) flux_tr(i, id_fine) = &
     158              flux_tr(i, id_fine) + (1 - fracso2emis) &
     159                      * (scale_param_bb(iregion_bb(i)) * lmt_so2bb_l(i) &
     160                              + scale_param_bb(iregion_bb(i)) * lmt_so2bb_h(i)) &
     161                      * (1. - pctsrf(i, is_oce)) &
     162                      * 1.e4 / RNAVO * masse_ammsulfate * 1.e3    ! mgS/m2/s
     163      !
     164      flux_sparam_bb(i) = &
     165              scale_param_bb(iregion_bb(i)) * (lmt_so2bb_l(i) + &
     166                      lmt_so2bb_h(i)) &
     167                      * (1. - pctsrf(i, is_oce)) * fracso2emis &
     168                      * 1.e4 / RNAVO * masse_s * 1.e3          ! mgS/m2/s
     169      flux_sparam_bb(i) = flux_sparam_bb(i) + (1 - fracso2emis) * &
     170              (scale_param_bb(iregion_bb(i)) * lmt_so2bb_l(i) + &
     171                      scale_param_bb(iregion_bb(i)) * lmt_so2bb_h(i)) &
     172              * (1. - pctsrf(i, is_oce)) &
     173              * 1.e4 / RNAVO * masse_ammsulfate * 1.e3    ! mgS/m2/s
     174    ENDIF
     175    IF(id_prec>0)   source_tr(i, id_prec) = source_tr(i, id_prec) &
     176            + fracso2emis &
     177                    * (lmt_so2ba(i) + lmt_so2nff(i)) * 1.e4 &
     178            + (lmt_h2sbio(i) &
     179                    + lmt_dms(i) + lmt_dmsbio(i)) * 1.e4            ! molec/m2/s
     180    !
     181    IF(id_fine>0)   source_tr(i, id_fine) = source_tr(i, id_fine) &
     182            + (1 - fracso2emis) &
     183                    * (lmt_so2ba(i) + lmt_so2nff(i)) * 1.e4 * &
     184                    masse_ammsulfate / RNAVO  ! g/m2/s
     185    !
     186    IF(id_prec>0)   flux_tr(i, id_prec) = flux_tr(i, id_prec) &
     187            + (lmt_h2sbio(i) &
     188                    + lmt_so2volc_cont(i) + lmt_so2volc_expl(i) &
     189                    + (lmt_so2ba(i) + lmt_so2nff(i)) * fracso2emis &
     190                    + lmt_dms(i) + lmt_dmsbio(i)) &
     191                    * 1.e4 / RNAVO * masse_s * 1.e3          ! mgS/m2/s
     192    !
     193    IF(id_fine>0)   flux_tr(i, id_fine) = flux_tr(i, id_fine) &
     194            + (1 - fracso2emis) &
     195                    * (lmt_so2ba(i) + lmt_so2nff(i)) &
     196                    * 1.e4 / RNAVO * masse_ammsulfate * 1.e3    ! mgS/m2/s
     197    !
     198    flux_sparam_ind(i) = flux_sparam_ind(i) + (1 - fracso2emis) &
     199            * lmt_so2nff(i) &
     200            * 1.e4 / RNAVO * masse_ammsulfate * 1.e3    ! mgS/m2/s
     201    !
     202  ENDDO
     203
     204  !========================================================================
     205  ! HIGH LEVEL EMISSIONS
     206  !========================================================================
     207  !  Source de SO2 volcaniques
     208  DO i = 1, klon
     209    kkk_cont(i) = 1
     210    kkk_expl(i) = 1
     211  ENDDO
     212  DO k = 1, klev - 1
     213    DO i = 1, klon
     214      zaltmid(i, k) = zalt(i, k) + zdz(i, k) / 2.
     215      IF (zalt(i, k + 1)<lmt_altvolc_cont(i)) kkk_cont(i) = k + 1
     216      IF (zalt(i, k + 1)<lmt_altvolc_expl(i)) kkk_expl(i) = k + 1
     217    ENDDO
     218  ENDDO
     219  IF(id_prec>0) THEN
     220    DO i = 1, klon
     221      tr_seri(i, kkk_cont(i), id_prec) = tr_seri(i, kkk_cont(i), id_prec) + &
     222              lmt_so2volc_cont(i) / zdz(i, kkk_cont(i)) / 100. * pdtphys
     223      tr_seri(i, kkk_expl(i), id_prec) = tr_seri(i, kkk_expl(i), id_prec) + &
     224              lmt_so2volc_expl(i) / zdz(i, kkk_expl(i)) / 100. * pdtphys
     225    ENDDO
     226  ENDIF
     227  !  Sources hautes de SO2
     228
     229  !
     230  !--only GEIA SO2 emissions has high emissions
     231  !--unit: molec/cm2/s divided by layer height (in cm) multiplied by timestep
     232  !
     233  k = 2                             !introducing emissions in level 2
     234  DO i = 1, klon
     235    !
     236    IF (iregion_bb(i)>0) THEN
     237      IF(id_prec>0)   tr_seri(i, k, id_prec) = &
     238              tr_seri(i, k, id_prec) + fracso2emis &
     239                      * scale_param_bb(iregion_bb(i)) * lmt_so2bb_h(i) &
     240                      / zdz(i, k) / 100. * pdtphys
     241      !
     242      IF(id_fine>0)     tr_seri(i, k, id_fine) = tr_seri(i, k, id_fine) &
     243              + (1. - fracso2emis) &
     244                      * scale_param_bb(iregion_bb(i)) * lmt_so2bb_h(i) &
     245                      * masse_ammsulfate / RNAVO / zdz(i, k) / 100. * pdtphys   !g/cm3
     246    ENDIF
     247    IF (iregion_ind(i)>0) THEN
     248      IF(id_prec>0)  tr_seri(i, k, id_prec) = &
     249              tr_seri(i, k, id_prec) + (fracso2emis &
     250                      * scale_param_ind(iregion_ind(i)) * lmt_so2ff_h(i) &
     251                      + frach2sofso2 &
     252                              * scale_param_ind(iregion_ind(i)) * lmt_so2ff_h(i)) &
     253                      / zdz(i, k) / 100. * pdtphys
     254      !
     255      IF(id_fine>0)    tr_seri(i, k, id_fine) = tr_seri(i, k, id_fine) &
     256              + (1. - fracso2emis) &
     257                      * scale_param_ind(iregion_ind(i)) * lmt_so2ff_h(i) &
     258                      * masse_ammsulfate / RNAVO / zdz(i, k) / 100. * pdtphys   !g/cm3
     259    ENDIF
     260    !
     261  ENDDO
     262
     263END SUBROUTINE precuremission

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/read_newemissions.f90

    r5103 r5104  
    1 C Routine to read the emissions of the different species
    2 C
    3       SUBROUTINE read_newemissions(julien, jH_emi ,edgar, flag_dms,
    4      I                             debutphy,
    5      I                             pdtphys,lafinphy, nbjour, pctsrf,
    6      I                             t_seri, xlat, xlon,
    7      I                             pmflxr, pmflxs, prfl, psfl,
    8      O                             u10m_ec, v10m_ec, dust_ec,
    9      O                             lmt_sea_salt, lmt_so2ff_l,
    10      O                             lmt_so2ff_h, lmt_so2nff, lmt_so2ba,
    11      O                             lmt_so2bb_l, lmt_so2bb_h,
    12      O                             lmt_so2volc_cont, lmt_altvolc_cont,
    13      O                             lmt_so2volc_expl, lmt_altvolc_expl,
    14      O                             lmt_dmsbio, lmt_h2sbio, lmt_dmsconc,
    15      O                             lmt_bcff, lmt_bcnff, lmt_bcbb_l,
    16      O                             lmt_bcbb_h, lmt_bcba, lmt_omff,
    17      O                             lmt_omnff, lmt_ombb_l, lmt_ombb_h,
    18      O                             lmt_omnat, lmt_omba)
    19      
    20       USE dimphy
    21       USE indice_sol_mod
    22       USE mod_grid_phy_lmdz
    23       USE mod_phys_lmdz_para
    24 
    25       IMPLICIT NONE
    26 
    27 
    28       INCLUDE "dimensions.h"
    29       INCLUDE 'paramet.h'
    30       INCLUDE 'chem.h'     
    31       INCLUDE 'chem_spla.h'
    32 
    33       logical debutphy, lafinphy, edgar
    34       INTEGER test_vent, test_day, step_vent, flag_dms, nbjour
    35       INTEGER julien, i, iday
    36       SAVE step_vent, test_vent, test_day, iday
    37 !$OMP THREADPRIVATE(step_vent, test_vent, test_day, iday)
    38       REAL pct_ocean(klon), pctsrf(klon,nbsrf)
    39       REAL pdtphys  ! pas d'integration pour la physique (seconde)     
    40       REAL t_seri(klon,klev)  ! temperature
    41 
    42       REAL xlat(klon)       ! latitudes pour chaque point
    43       REAL xlon(klon)       ! longitudes pour chaque point
    44      
    45 c
    46 c   Emissions:
    47 c   ---------
    48 c
    49 c---------------------------- SEA SALT & DUST emissions ------------------------
    50       REAL lmt_sea_salt(klon,ss_bins) !Sea salt 0.03-8.0 um !NOT SAVED OK
    51       REAL clyfac, avgdryrate, drying
    52 c je      REAL u10m_ec1(klon), v10m_ec1(klon), dust_ec1(klon)
    53 c je      REAL u10m_ec2(klon), v10m_ec2(klon), dust_ec2(klon)
    54 
    55       REAL, SAVE, ALLOCATABLE :: u10m_ec1(:), v10m_ec1(:), dust_ec1(:)
    56       REAL, SAVE, ALLOCATABLE :: u10m_ec2(:), v10m_ec2(:), dust_ec2(:)
    57 !$OMP THREADPRIVATE(u10m_ec1, v10m_ec1, dust_ec1)
    58 !$OMP THREADPRIVATE(u10m_ec2, v10m_ec2, dust_ec2)
    59 c as      REAL u10m_nc(iip1,jjp1), v10m_nc(iip1,jjp1)
    60       REAL u10m_ec(klon), v10m_ec(klon), dust_ec(klon)
    61 c      REAL cly(klon), wth(klon), zprecipinsoil(klon)
    62       REAL, SAVE, ALLOCATABLE :: cly(:), wth(:), zprecipinsoil(:)
    63       REAL :: cly_glo(klon_glo), wth_glo(klon_glo)
    64       REAL :: zprecipinsoil_glo(klon_glo)
    65 !$OMP THREADPRIVATE(cly,wth,zprecipinsoil)
    66 
    67 
    68 c je     SAVE u10m_ec2, v10m_ec2, dust_ec2
    69 c je      SAVE u10m_ec1, v10m_ec1, dust_ec1   ! Added on titane
    70 c je      SAVE cly, wth, zprecipinsoil        ! Added on titane
    71 !     SAVE cly, wth, zprecipinsoil, u10m_ec2, v10m_ec2, dust_ec2
    72 c------------------------- BLACK CARBON emissions ----------------------
    73       REAL lmt_bcff(klon)       ! emissions de BC fossil fuels
    74       REAL lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
    75       REAL lmt_bcbb_l(klon)     ! emissions de BC biomass basses
    76       REAL lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
    77       REAL lmt_bcba(klon)       ! emissions de BC bateau
    78 c------------------------ ORGANIC MATTER emissions ---------------------
    79       REAL lmt_omff(klon)     ! emissions de OM fossil fuels
    80       REAL lmt_omnff(klon)    ! emissions de OM non-fossil fuels
    81       REAL lmt_ombb_l(klon)   ! emissions de OM biomass basses
    82       REAL lmt_ombb_h(klon)   ! emissions de OM biomass hautes
    83       REAL lmt_omnat(klon)    ! emissions de OM Natural
    84       REAL lmt_omba(klon)     ! emissions de OM bateau
    85 c------------------------- SULFUR emissions ----------------------------
    86       REAL lmt_so2ff_l(klon)       ! emissions so2 fossil fuels (low)
    87       REAL lmt_so2ff_h(klon)       ! emissions so2 fossil fuels (high)
    88       REAL lmt_so2nff(klon)        ! emissions so2 non-fossil fuels
    89       REAL lmt_so2bb_l(klon)       ! emissions de so2 biomass burning basse
    90       REAL lmt_so2bb_h(klon)       ! emissions de so2 biomass burning hautes
    91       REAL lmt_so2ba(klon)         ! emissions de so2 bateau
    92       REAL lmt_so2volc_cont(klon)  ! emissions so2 volcan continuous
    93       REAL lmt_altvolc_cont(klon)  ! altitude  so2 volcan continuous
    94       REAL lmt_so2volc_expl(klon)  ! emissions so2 volcan explosive
    95       REAL lmt_altvolc_expl(klon)  ! altitude  so2 volcan explosive
    96       REAL lmt_dmsconc(klon)       ! concentration de dms oceanique
    97       REAL lmt_dmsbio(klon)        ! emissions de dms bio
    98       REAL lmt_h2sbio(klon)        ! emissions de h2s bio
    99 
    100       REAL,SAVE,ALLOCATABLE ::  lmt_dms(:)           ! emissions de dms
    101 !$OMP THREADPRIVATE(lmt_dms)
    102 c
    103 c  Lessivage
    104 c  ---------
    105 c
    106       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) !--convection
    107       REAL prfl(klon,klev+1),   psfl(klon,klev+1)   !--large-scale
    108 !      REAL pmflxr(klon,klev), pmflxs(klon,klev) !--convection
    109 !      REAL prfl(klon,klev),   psfl(klon,klev)   !--large-scale
    110 c
    111 c  Variable interne
    112 c  ----------------
    113 c     
    114       INTEGER icount
    115       REAL tau_1, tau_2                 
    116       REAL max_flux, min_flux                                         
    117       INTRINSIC MIN, MAX
    118 c
    119 c JE: Changes due to new pdtphys in new physics.
    120 c      REAL windintime ! time in hours of the wind input files resolution
    121 c      REAL dayemintime ! time in hours of the other emissions input files resolution
    122       REAL jH_init ! shift in the hour (count as days) respecto to
    123 !                  ! realhour = (pdtphys*i)/3600/24 -days_elapsed
    124       REAL jH_emi,jH_vent,jH_day
    125       SAVE jH_init,jH_vent,jH_day
    126 !$OMP THREADPRIVATE(jH_init,jH_vent,jH_day)
    127       REAL,PARAMETER :: vent_resol = 6. ! resolution of winds in hours
    128       REAL,PARAMETER :: day_resol = 24. ! resolution of daily emmis. in hours
    129 !      INTEGER   test_day1
    130 !      SAVE test_day1
    131 !      REAL tau_1j,tau_2j
    132 c je
    133 c allocate if necessary
    134 c
    135 
    136       IF (.NOT. ALLOCATED(u10m_ec1)) ALLOCATE(u10m_ec1(klon))
    137       IF (.NOT. ALLOCATED(v10m_ec1)) ALLOCATE(v10m_ec1(klon))
    138       IF (.NOT. ALLOCATED(dust_ec1)) ALLOCATE(dust_ec1(klon))
    139       IF (.NOT. ALLOCATED(u10m_ec2)) ALLOCATE(u10m_ec2(klon))
    140       IF (.NOT. ALLOCATED(v10m_ec2)) ALLOCATE(v10m_ec2(klon))
    141       IF (.NOT. ALLOCATED(dust_ec2)) ALLOCATE(dust_ec2(klon))
    142       IF (.NOT. ALLOCATED(cly)) ALLOCATE(cly(klon))
    143       IF (.NOT. ALLOCATED(wth)) ALLOCATE(wth(klon))
    144       IF (.NOT. ALLOCATED(zprecipinsoil)) ALLOCATE(zprecipinsoil(klon))
    145       IF (.NOT. ALLOCATED(lmt_dms)) ALLOCATE(lmt_dms(klon))
    146 c end je nov2013
    147 c
    148 C***********************************************************************
    149 C DUST EMISSIONS
    150 C***********************************************************************
    151 c
    152       IF (debutphy) THEN
    153 C---Fields are read only at the beginning of the period
    154 c--reading wind and dust
    155         iday=julien
    156         step_vent=1
    157         test_vent=0
    158         test_day=0
    159         CALL read_vent(.TRUE.,step_vent,nbjour,u10m_ec2,v10m_ec2)
    160         print *,'Read (debut) dust emissions: step_vent,julien,nbjour',
    161      .                                   step_vent,julien,nbjour
    162         CALL read_dust(.TRUE.,step_vent,nbjour,dust_ec2)
    163 C Threshold velocity map
    164 !$OMP MASTER
    165        IF (is_mpi_root .AND. is_omp_root) THEN
    166         zprecipinsoil_glo(:)=0.0
    167         OPEN(51,file='wth.dat',status='unknown',form='formatted')
    168         READ(51,'(G18.10)') (wth_glo(i),i=1,klon_glo)
    169         CLOSE(51)
    170 c Clay content
    171         OPEN(52,file='cly.dat',status='unknown',form='formatted')
    172         READ(52,'(G18.10)') (cly_glo(i),i=1,klon_glo)
    173         CLOSE(52)
    174         OPEN(53,file='precipinsoil.dat',
    175      .        status='old',form='formatted',err=999)
    176         READ(53,'(G18.10)') (zprecipinsoil_glo(i),i=1,klon_glo)
    177         PRINT *,'lecture precipinsoil.dat'
    178  999    CONTINUE
    179         CLOSE(53)
    180        ENDIF
    181 !$OMP END MASTER
    182 !$OMP BARRIER
    183        CALL scatter(wth_glo,wth)
    184        CALL scatter(cly_glo,cly)
    185        CALL scatter(zprecipinsoil_glo,zprecipinsoil)
    186 
    187 !JE20140908<<        GOTO 1000
    188 !        DO i=1, klon
    189 !          zprecipinsoil(i)=0.0
    190 !        ENDDO
    191 ! 1000   CLOSE(53)
    192 !JE20140908>>
    193         jH_init=jH_emi
    194         jH_vent=jH_emi
    195         jH_day=jH_emi
    196 !        test_day1=0
    197 !JE end
    198 c
    199      
    200       ENDIF !--- debutphy
    201        
    202       print *,'READ_EMISSION: test_vent & test_day = ',test_vent,
    203      +                                                 test_day
    204       IF (test_vent==0) THEN    !--on lit toutes les 6 h
    205         CALL SCOPY(klon, u10m_ec2, 1, u10m_ec1, 1)
    206         CALL SCOPY(klon, v10m_ec2, 1, v10m_ec1, 1)
    207         CALL SCOPY(klon, dust_ec2, 1, dust_ec1, 1)
    208         step_vent=step_vent+1
    209         !PRINT *,'step_vent=', step_vent
    210         CALL read_vent(.FALSE.,step_vent,nbjour,u10m_ec2,v10m_ec2)
    211         print *,'Reading dust emissions: step_vent, julien, nbjour ',
    212      .                                   step_vent, julien, nbjour
    213         !print *,'test_vent, julien = ',test_vent, julien
    214         CALL read_dust(.FALSE.,step_vent,nbjour,dust_ec2)
    215      
    216       ENDIF !--test_vent
    217 
    218 c     ubicacion original
    219 c      test_vent=test_vent+1
    220 c      IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
    221            
    222 !JE      tau_2=FLOAT(test_vent)/12.
    223 !JE      tau_1=1.-tau_2
    224       tau_2=(jH_vent-jH_init)*24./(vent_resol)
    225       tau_1=1.-tau_2
    226 !      PRINT*,'JEdec jHv,JHi,ventres',jH_vent,jH_init,vent_resol
    227 !      PRINT*,'JEdec tau2,tau1',tau_2,tau_1
    228 !      PRINT*,'JEdec step_vent',step_vent
    229       DO i=1, klon
    230 !      PRINT*,'JE tau_2,tau_2j',tau_2,tau_2j
    231         u10m_ec(i)=tau_1*u10m_ec1(i)+tau_2*u10m_ec2(i)
    232         v10m_ec(i)=tau_1*v10m_ec1(i)+tau_2*v10m_ec2(i)
    233         dust_ec(i)=tau_1*dust_ec1(i)+tau_2*dust_ec2(i)
    234       ENDDO
    235 c
    236 cJE      IF (test_vent.EQ.(6*2)) THEN
    237 cJE        PRINT *,'6 hrs interval reached'
    238 cJE        print *,'day in read_emission, test_vent = ',julien, test_vent
    239 cJE      ENDIF
    240 cJE
    241 !JE      test_vent=test_vent+1
    242 !JE      IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
    243 c JE 
    244       jH_vent=jH_vent+pdtphys/(24.*3600.)
    245       test_vent=test_vent+1
    246       IF (jH_vent>(vent_resol)/24.) THEN
    247           test_vent=0
    248           jH_vent=jH_init
    249       ENDIF
    250 !      PRINT*,'JE test_vent,test_vent1,jH_vent ', test_vent,test_vent1
    251 !     .     ,jH_vent
    252 c endJEi
    253 c
    254       avgdryrate=300./365.*pdtphys/86400.
    255 c
    256       DO i=1, klon
    257 c
    258         IF (cly(i)<9990..AND.wth(i)<9990.) THEN
    259           zprecipinsoil(i)=zprecipinsoil(i) +
    260      .           (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
    261 c
    262           clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
    263           drying=avgdryrate*exp(0.03905491*
    264      .                    exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
    265           zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
    266         ENDIF
    267 !        zprecipinsoil(i)=0.0 ! Temporarely introduced to reproduce obelix result
    268       ENDDO
    269 
    270 !      print *,'cly = ',sum(cly),maxval(cly),minval(cly)
    271 !      print *,'wth = ',sum(wth),maxval(wth),minval(wth)
    272 !      print *,'t_seri = ',sum(t_seri),maxval(t_seri),minval(t_seri)
    273 !      print *,'precipinsoil = ',sum(zprecipinsoil),maxval(zprecipinsoil)
    274 !     .                      ,minval(zprecipinsoil)
    275       icount=0
    276       DO i=1, klon
    277         IF (cly(i)>=9990..OR.wth(i)>=9990..OR.
    278      .     t_seri(i,1)<=273.15.OR.zprecipinsoil(i)>1.e-8) THEN
    279              dust_ec(i)=0.0 ! commented out for test dustemtest
    280 !             print *,'Dust emissions surpressed at grid = ',i
    281 !             icount=icount+1
    282         ENDIF
    283       ENDDO                           
    284 c
    285       print *,'Total N of grids with surpressed emission = ',icount
    286       print *,'dust_ec = ',SUM(dust_ec),MINVAL(dust_ec),
    287      .                                  MAXVAL(dust_ec)
    288 cnhl Transitory scaling of desert dust emissions
    289      
    290 cnhl      DO i=1, klon
    291 cnhl         dust_ec(i)=dust_ec(i)/2.
    292 cnhl      ENDDO                           
    293 
    294 C-saving precipitation field to be read in next simulation
    295      
    296       IF (lafinphy) THEN
    297 c
    298         CALL gather(zprecipinsoil,zprecipinsoil_glo)
    299 !$OMP MASTER
    300         IF (is_mpi_root .AND. is_omp_root) THEN
    301 
    302         OPEN(53,file='newprecipinsoil.dat',
    303      .          status='unknown',form='formatted')
    304         WRITE(53,'(G18.10)') (zprecipinsoil_glo(i),i=1,klon_glo)
    305         CLOSE(53)
    306         ENDIF
    307 !$OMP END MASTER
    308 !$OMP BARRIER
    309 c
    310       ENDIF
    311 c
    312 C***********************************************************************
    313 C SEA SALT EMISSIONS
    314 C***********************************************************************
    315 c
    316       DO i=1,klon
    317         pct_ocean(i)=pctsrf(i,is_oce)
    318       ENDDO
    319 
    320       print *,'IS_OCE = ',is_oce
    321       CALL seasalt(v10m_ec, u10m_ec, pct_ocean, lmt_sea_salt) !mgSeaSalt/cm2/s
    322 !      print *,'SUM, MAX & MIN Sea Salt = ',SUM(lmt_sea_salt),
    323 !     .               MAXVAL(lmt_sea_salt),MINVAL(lmt_sea_salt)
    324 c     
    325 C***********************************************************************
    326 C SULFUR & CARBON EMISSIONS
    327 C***********************************************************************
    328 c
    329      
    330       IF (test_day==0) THEN
    331         print *,'Computing SULFATE emissions for day : ',iday,julien,
    332      .                                                   step_vent
    333         CALL condsurfs_new(iday, edgar, flag_dms,
    334      O                      lmt_so2ff_l, lmt_so2ff_h, lmt_so2nff,
    335      O                      lmt_so2bb_l, lmt_so2bb_h, lmt_so2ba,
    336      O                      lmt_so2volc_cont, lmt_altvolc_cont,
    337      O                      lmt_so2volc_expl, lmt_altvolc_expl,
    338      O                      lmt_dmsbio, lmt_h2sbio, lmt_dms,lmt_dmsconc)
    339         print *,'Computing CARBON emissions for day : ',iday,julien,
    340      .                                                   step_vent
    341         CALL condsurfc_new(iday,
    342      O                       lmt_bcff,lmt_bcnff,lmt_bcbb_l,lmt_bcbb_h,
    343      O                       lmt_bcba,lmt_omff,lmt_omnff,lmt_ombb_l,
    344      O                       lmt_ombb_h, lmt_omnat, lmt_omba)
    345         print *,'IDAY = ',iday
    346         iday=iday+1
    347         print *,'BCBB_L emissions :',SUM(lmt_bcbb_l), MAXVAL(lmt_bcbb_l)
    348      .                              ,MINVAL(lmt_bcbb_l)
    349         print *,'BCBB_H emissions :',SUM(lmt_bcbb_h), MAXVAL(lmt_bcbb_h)
    350      .                              ,MINVAL(lmt_bcbb_h)
    351       ENDIF
    352      
    353 !JE      test_day=test_day+1
    354 !JE      IF (test_day.EQ.(24*2.)) THEN
    355 !JE        test_day=0 !on remet a zero ttes les 24 h
    356 !JE        print *,'LAST TIME STEP OF DAY ',julien
    357 !JE      ENDIF
    358 
    359 
    360       jH_day=jH_day+pdtphys/(24.*3600.)
    361       test_day=test_day+1
    362       IF (jH_day>(day_resol)/24.) THEN
    363           print *,'LAST TIME STEP OF DAY ',julien
    364           test_day=0
    365           jH_day=jH_init
    366       ENDIF
    367 !      PRINT*,'test_day,test_day1',test_day,test_day1
    368 
    369       END
     1! Routine to read the emissions of the different species
     2!
     3SUBROUTINE read_newemissions(julien, jH_emi, edgar, flag_dms, &
     4        debutphy, &
     5        pdtphys, lafinphy, nbjour, pctsrf, &
     6        t_seri, xlat, xlon, &
     7        pmflxr, pmflxs, prfl, psfl, &
     8        u10m_ec, v10m_ec, dust_ec, &
     9        lmt_sea_salt, lmt_so2ff_l, &
     10        lmt_so2ff_h, lmt_so2nff, lmt_so2ba, &
     11        lmt_so2bb_l, lmt_so2bb_h, &
     12        lmt_so2volc_cont, lmt_altvolc_cont, &
     13        lmt_so2volc_expl, lmt_altvolc_expl, &
     14        lmt_dmsbio, lmt_h2sbio, lmt_dmsconc, &
     15        lmt_bcff, lmt_bcnff, lmt_bcbb_l, &
     16        lmt_bcbb_h, lmt_bcba, lmt_omff, &
     17        lmt_omnff, lmt_ombb_l, lmt_ombb_h, &
     18        lmt_omnat, lmt_omba)
     19
     20  USE dimphy
     21  USE indice_sol_mod
     22  USE mod_grid_phy_lmdz
     23  USE mod_phys_lmdz_para
     24
     25  IMPLICIT NONE
     26
     27  INCLUDE "dimensions.h"
     28  INCLUDE 'paramet.h'
     29  INCLUDE 'chem.h'
     30  INCLUDE 'chem_spla.h'
     31
     32  logical :: debutphy, lafinphy, edgar
     33  INTEGER :: test_vent, test_day, step_vent, flag_dms, nbjour
     34  INTEGER :: julien, i, iday
     35  SAVE step_vent, test_vent, test_day, iday
     36  !$OMP THREADPRIVATE(step_vent, test_vent, test_day, iday)
     37  REAL :: pct_ocean(klon), pctsrf(klon, nbsrf)
     38  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
     39  REAL :: t_seri(klon, klev)  ! temperature
     40
     41  REAL :: xlat(klon)       ! latitudes pour chaque point
     42  REAL :: xlon(klon)       ! longitudes pour chaque point
     43
     44  !
     45  !   Emissions:
     46  !   ---------
     47  !
     48  !---------------------------- SEA SALT & DUST emissions ------------------------
     49  REAL :: lmt_sea_salt(klon, ss_bins) !Sea salt 0.03-8.0 um !NOT SAVED OK
     50  REAL :: clyfac, avgdryrate, drying
     51  ! je      REAL u10m_ec1(klon), v10m_ec1(klon), dust_ec1(klon)
     52  ! je      REAL u10m_ec2(klon), v10m_ec2(klon), dust_ec2(klon)
     53
     54  REAL, SAVE, ALLOCATABLE :: u10m_ec1(:), v10m_ec1(:), dust_ec1(:)
     55  REAL, SAVE, ALLOCATABLE :: u10m_ec2(:), v10m_ec2(:), dust_ec2(:)
     56  !$OMP THREADPRIVATE(u10m_ec1, v10m_ec1, dust_ec1)
     57  !$OMP THREADPRIVATE(u10m_ec2, v10m_ec2, dust_ec2)
     58  ! as      REAL u10m_nc(iip1,jjp1), v10m_nc(iip1,jjp1)
     59  REAL :: u10m_ec(klon), v10m_ec(klon), dust_ec(klon)
     60  !      REAL cly(klon), wth(klon), zprecipinsoil(klon)
     61  REAL, SAVE, ALLOCATABLE :: cly(:), wth(:), zprecipinsoil(:)
     62  REAL :: cly_glo(klon_glo), wth_glo(klon_glo)
     63  REAL :: zprecipinsoil_glo(klon_glo)
     64  !$OMP THREADPRIVATE(cly,wth,zprecipinsoil)
     65
     66
     67  ! je     SAVE u10m_ec2, v10m_ec2, dust_ec2
     68  ! je      SAVE u10m_ec1, v10m_ec1, dust_ec1   ! Added on titane
     69  ! je      SAVE cly, wth, zprecipinsoil        ! Added on titane
     70  ! SAVE cly, wth, zprecipinsoil, u10m_ec2, v10m_ec2, dust_ec2
     71  !------------------------- BLACK CARBON emissions ----------------------
     72  REAL :: lmt_bcff(klon)       ! emissions de BC fossil fuels
     73  REAL :: lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
     74  REAL :: lmt_bcbb_l(klon)     ! emissions de BC biomass basses
     75  REAL :: lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
     76  REAL :: lmt_bcba(klon)       ! emissions de BC bateau
     77  !------------------------ ORGANIC MATTER emissions ---------------------
     78  REAL :: lmt_omff(klon)     ! emissions de OM fossil fuels
     79  REAL :: lmt_omnff(klon)    ! emissions de OM non-fossil fuels
     80  REAL :: lmt_ombb_l(klon)   ! emissions de OM biomass basses
     81  REAL :: lmt_ombb_h(klon)   ! emissions de OM biomass hautes
     82  REAL :: lmt_omnat(klon)    ! emissions de OM Natural
     83  REAL :: lmt_omba(klon)     ! emissions de OM bateau
     84  !------------------------- SULFUR emissions ----------------------------
     85  REAL :: lmt_so2ff_l(klon)       ! emissions so2 fossil fuels (low)
     86  REAL :: lmt_so2ff_h(klon)       ! emissions so2 fossil fuels (high)
     87  REAL :: lmt_so2nff(klon)        ! emissions so2 non-fossil fuels
     88  REAL :: lmt_so2bb_l(klon)       ! emissions de so2 biomass burning basse
     89  REAL :: lmt_so2bb_h(klon)       ! emissions de so2 biomass burning hautes
     90  REAL :: lmt_so2ba(klon)         ! emissions de so2 bateau
     91  REAL :: lmt_so2volc_cont(klon)  ! emissions so2 volcan continuous
     92  REAL :: lmt_altvolc_cont(klon)  ! altitude  so2 volcan continuous
     93  REAL :: lmt_so2volc_expl(klon)  ! emissions so2 volcan explosive
     94  REAL :: lmt_altvolc_expl(klon)  ! altitude  so2 volcan explosive
     95  REAL :: lmt_dmsconc(klon)       ! concentration de dms oceanique
     96  REAL :: lmt_dmsbio(klon)        ! emissions de dms bio
     97  REAL :: lmt_h2sbio(klon)        ! emissions de h2s bio
     98
     99  REAL, SAVE, ALLOCATABLE :: lmt_dms(:)           ! emissions de dms
     100  !$OMP THREADPRIVATE(lmt_dms)
     101  !
     102  !  Lessivage
     103  !  ---------
     104  !
     105  REAL :: pmflxr(klon, klev + 1), pmflxs(klon, klev + 1) !--convection
     106  REAL :: prfl(klon, klev + 1), psfl(klon, klev + 1)   !--large-scale
     107  ! REAL pmflxr(klon,klev), pmflxs(klon,klev) !--convection
     108  ! REAL prfl(klon,klev),   psfl(klon,klev)   !--large-scale
     109  !
     110  !  Variable interne
     111  !  ----------------
     112  !
     113  INTEGER :: icount
     114  REAL :: tau_1, tau_2
     115  REAL :: max_flux, min_flux
     116  INTRINSIC MIN, MAX
     117  !
     118  ! JE: Changes due to new pdtphys in new physics.
     119  !  REAL windintime ! time in hours of the wind input files resolution
     120  !  REAL dayemintime ! time in hours of the other emissions input files resolution
     121  REAL :: jH_init ! shift in the hour (count as days) respecto to
     122  ! ! realhour = (pdtphys*i)/3600/24 -days_elapsed
     123  REAL :: jH_emi, jH_vent, jH_day
     124  SAVE jH_init, jH_vent, jH_day
     125  !$OMP THREADPRIVATE(jH_init,jH_vent,jH_day)
     126  REAL, PARAMETER :: vent_resol = 6. ! resolution of winds in hours
     127  REAL, PARAMETER :: day_resol = 24. ! resolution of daily emmis. in hours
     128  ! INTEGER   test_day1
     129  ! SAVE test_day1
     130  ! REAL tau_1j,tau_2j
     131  ! je
     132  ! allocate if necessary
     133  !
     134
     135  IF (.NOT. ALLOCATED(u10m_ec1)) ALLOCATE(u10m_ec1(klon))
     136  IF (.NOT. ALLOCATED(v10m_ec1)) ALLOCATE(v10m_ec1(klon))
     137  IF (.NOT. ALLOCATED(dust_ec1)) ALLOCATE(dust_ec1(klon))
     138  IF (.NOT. ALLOCATED(u10m_ec2)) ALLOCATE(u10m_ec2(klon))
     139  IF (.NOT. ALLOCATED(v10m_ec2)) ALLOCATE(v10m_ec2(klon))
     140  IF (.NOT. ALLOCATED(dust_ec2)) ALLOCATE(dust_ec2(klon))
     141  IF (.NOT. ALLOCATED(cly)) ALLOCATE(cly(klon))
     142  IF (.NOT. ALLOCATED(wth)) ALLOCATE(wth(klon))
     143  IF (.NOT. ALLOCATED(zprecipinsoil)) ALLOCATE(zprecipinsoil(klon))
     144  IF (.NOT. ALLOCATED(lmt_dms)) ALLOCATE(lmt_dms(klon))
     145  ! end je nov2013
     146  !
     147  !***********************************************************************
     148  ! DUST EMISSIONS
     149  !***********************************************************************
     150  !
     151  IF (debutphy) THEN
     152    !---Fields are read only at the beginning of the period
     153    !--reading wind and dust
     154    iday = julien
     155    step_vent = 1
     156    test_vent = 0
     157    test_day = 0
     158    CALL read_vent(.TRUE., step_vent, nbjour, u10m_ec2, v10m_ec2)
     159    print *, 'Read (debut) dust emissions: step_vent,julien,nbjour', &
     160            step_vent, julien, nbjour
     161    CALL read_dust(.TRUE., step_vent, nbjour, dust_ec2)
     162    ! Threshold velocity map
     163    !$OMP MASTER
     164    IF (is_mpi_root .AND. is_omp_root) THEN
     165      zprecipinsoil_glo(:) = 0.0
     166      OPEN(51, file = 'wth.dat', status = 'unknown', form = 'formatted')
     167      READ(51, '(G18.10)') (wth_glo(i), i = 1, klon_glo)
     168      CLOSE(51)
     169      ! Clay content
     170      OPEN(52, file = 'cly.dat', status = 'unknown', form = 'formatted')
     171      READ(52, '(G18.10)') (cly_glo(i), i = 1, klon_glo)
     172      CLOSE(52)
     173      OPEN(53, file = 'precipinsoil.dat', &
     174              status = 'old', form = 'formatted', err = 999)
     175      READ(53, '(G18.10)') (zprecipinsoil_glo(i), i = 1, klon_glo)
     176      PRINT *, 'lecture precipinsoil.dat'
     177      999   CONTINUE
     178      CLOSE(53)
     179    ENDIF
     180    !$OMP END MASTER
     181    !$OMP BARRIER
     182    CALL scatter(wth_glo, wth)
     183    CALL scatter(cly_glo, cly)
     184    CALL scatter(zprecipinsoil_glo, zprecipinsoil)
     185
     186    !JE20140908<<        GOTO 1000
     187    ! DO i=1, klon
     188    !   zprecipinsoil(i)=0.0
     189    ! ENDDO
     190    ! 1000   CLOSE(53)
     191    !JE20140908>>
     192    jH_init = jH_emi
     193    jH_vent = jH_emi
     194    jH_day = jH_emi
     195    ! test_day1=0
     196    !JE end
     197    !
     198
     199  ENDIF !--- debutphy
     200
     201  print *, 'READ_EMISSION: test_vent & test_day = ', test_vent, &
     202          test_day
     203  IF (test_vent==0) THEN    !--on lit toutes les 6 h
     204    CALL SCOPY(klon, u10m_ec2, 1, u10m_ec1, 1)
     205    CALL SCOPY(klon, v10m_ec2, 1, v10m_ec1, 1)
     206    CALL SCOPY(klon, dust_ec2, 1, dust_ec1, 1)
     207    step_vent = step_vent + 1
     208    ! !PRINT *,'step_vent=', step_vent
     209    CALL read_vent(.FALSE., step_vent, nbjour, u10m_ec2, v10m_ec2)
     210    print *, 'Reading dust emissions: step_vent, julien, nbjour ', &
     211            step_vent, julien, nbjour
     212    ! !print *,'test_vent, julien = ',test_vent, julien
     213    CALL read_dust(.FALSE., step_vent, nbjour, dust_ec2)
     214
     215  ENDIF !--test_vent
     216
     217  ! ubicacion original
     218  !  test_vent=test_vent+1
     219  !  IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
     220
     221  !JE      tau_2=FLOAT(test_vent)/12.
     222  !JE      tau_1=1.-tau_2
     223  tau_2 = (jH_vent - jH_init) * 24. / (vent_resol)
     224  tau_1 = 1. - tau_2
     225  ! PRINT*,'JEdec jHv,JHi,ventres',jH_vent,jH_init,vent_resol
     226  ! PRINT*,'JEdec tau2,tau1',tau_2,tau_1
     227  ! PRINT*,'JEdec step_vent',step_vent
     228  DO i = 1, klon
     229    ! PRINT*,'JE tau_2,tau_2j',tau_2,tau_2j
     230    u10m_ec(i) = tau_1 * u10m_ec1(i) + tau_2 * u10m_ec2(i)
     231    v10m_ec(i) = tau_1 * v10m_ec1(i) + tau_2 * v10m_ec2(i)
     232    dust_ec(i) = tau_1 * dust_ec1(i) + tau_2 * dust_ec2(i)
     233  ENDDO
     234  !
     235  !JE      IF (test_vent.EQ.(6*2)) THEN
     236  !JE        PRINT *,'6 hrs interval reached'
     237  !JE        print *,'day in read_emission, test_vent = ',julien, test_vent
     238  !JE      ENDIF
     239  !JE
     240  !JE      test_vent=test_vent+1
     241  !JE      IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
     242  ! JE
     243  jH_vent = jH_vent + pdtphys / (24. * 3600.)
     244  test_vent = test_vent + 1
     245  IF (jH_vent>(vent_resol) / 24.) THEN
     246    test_vent = 0
     247    jH_vent = jH_init
     248  ENDIF
     249  ! PRINT*,'JE test_vent,test_vent1,jH_vent ', test_vent,test_vent1
     250  ! .     ,jH_vent
     251  ! endJEi
     252  !
     253  avgdryrate = 300. / 365. * pdtphys / 86400.
     254  !
     255  DO i = 1, klon
     256    !
     257    IF (cly(i)<9990..AND.wth(i)<9990.) THEN
     258      zprecipinsoil(i) = zprecipinsoil(i) + &
     259              (pmflxr(i, 1) + pmflxs(i, 1) + prfl(i, 1) + psfl(i, 1)) * pdtphys
     260      !
     261      clyfac = MIN(16., cly(i) * 0.4 + 8.) ![mm] max amount of water hold in top soil
     262      drying = avgdryrate * exp(0.03905491 * &
     263              exp(0.17446 * (t_seri(i, 1) - 273.15))) ! [mm]
     264      zprecipinsoil(i) = min(max(0., zprecipinsoil(i) - drying), clyfac) ! [mm]
     265    ENDIF
     266    ! zprecipinsoil(i)=0.0 ! Temporarely introduced to reproduce obelix result
     267  ENDDO
     268
     269  ! print *,'cly = ',sum(cly),maxval(cly),minval(cly)
     270  ! print *,'wth = ',sum(wth),maxval(wth),minval(wth)
     271  ! print *,'t_seri = ',sum(t_seri),maxval(t_seri),minval(t_seri)
     272  ! print *,'precipinsoil = ',sum(zprecipinsoil),maxval(zprecipinsoil)
     273  ! .                      ,minval(zprecipinsoil)
     274  icount = 0
     275  DO i = 1, klon
     276    IF (cly(i)>=9990..OR.wth(i)>=9990..OR. &
     277            t_seri(i, 1)<=273.15.OR.zprecipinsoil(i)>1.e-8) THEN
     278      dust_ec(i) = 0.0 ! commented out for test dustemtest
     279      ! print *,'Dust emissions surpressed at grid = ',i
     280      ! icount=icount+1
     281    ENDIF
     282  ENDDO
     283  !
     284  print *, 'Total N of grids with surpressed emission = ', icount
     285  print *, 'dust_ec = ', SUM(dust_ec), MINVAL(dust_ec), &
     286          MAXVAL(dust_ec)
     287  !nhl Transitory scaling of desert dust emissions
     288
     289  !nhl      DO i=1, klon
     290  !nhl         dust_ec(i)=dust_ec(i)/2.
     291  !nhl      ENDDO
     292
     293  !-saving precipitation field to be read in next simulation
     294
     295  IF (lafinphy) THEN
     296    !
     297    CALL gather(zprecipinsoil, zprecipinsoil_glo)
     298    !$OMP MASTER
     299    IF (is_mpi_root .AND. is_omp_root) THEN
     300
     301      OPEN(53, file = 'newprecipinsoil.dat', &
     302              status = 'unknown', form = 'formatted')
     303      WRITE(53, '(G18.10)') (zprecipinsoil_glo(i), i = 1, klon_glo)
     304      CLOSE(53)
     305    ENDIF
     306    !$OMP END MASTER
     307    !$OMP BARRIER
     308    !
     309  ENDIF
     310  !
     311  !***********************************************************************
     312  ! SEA SALT EMISSIONS
     313  !***********************************************************************
     314  !
     315  DO i = 1, klon
     316    pct_ocean(i) = pctsrf(i, is_oce)
     317  ENDDO
     318
     319  print *, 'IS_OCE = ', is_oce
     320  CALL seasalt(v10m_ec, u10m_ec, pct_ocean, lmt_sea_salt) !mgSeaSalt/cm2/s
     321  ! print *,'SUM, MAX & MIN Sea Salt = ',SUM(lmt_sea_salt),
     322  ! .               MAXVAL(lmt_sea_salt),MINVAL(lmt_sea_salt)
     323  !
     324  !***********************************************************************
     325  ! SULFUR & CARBON EMISSIONS
     326  !***********************************************************************
     327  !
     328
     329  IF (test_day==0) THEN
     330    print *, 'Computing SULFATE emissions for day : ', iday, julien, &
     331            step_vent
     332    CALL condsurfs_new(iday, edgar, flag_dms, &
     333            lmt_so2ff_l, lmt_so2ff_h, lmt_so2nff, &
     334            lmt_so2bb_l, lmt_so2bb_h, lmt_so2ba, &
     335            lmt_so2volc_cont, lmt_altvolc_cont, &
     336            lmt_so2volc_expl, lmt_altvolc_expl, &
     337            lmt_dmsbio, lmt_h2sbio, lmt_dms, lmt_dmsconc)
     338    print *, 'Computing CARBON emissions for day : ', iday, julien, &
     339            step_vent
     340    CALL condsurfc_new(iday, &
     341            lmt_bcff, lmt_bcnff, lmt_bcbb_l, lmt_bcbb_h, &
     342            lmt_bcba, lmt_omff, lmt_omnff, lmt_ombb_l, &
     343            lmt_ombb_h, lmt_omnat, lmt_omba)
     344    print *, 'IDAY = ', iday
     345    iday = iday + 1
     346    print *, 'BCBB_L emissions :', SUM(lmt_bcbb_l), MAXVAL(lmt_bcbb_l) &
     347            , MINVAL(lmt_bcbb_l)
     348    print *, 'BCBB_H emissions :', SUM(lmt_bcbb_h), MAXVAL(lmt_bcbb_h) &
     349            , MINVAL(lmt_bcbb_h)
     350  ENDIF
     351
     352  !JE      test_day=test_day+1
     353  !JE      IF (test_day.EQ.(24*2.)) THEN
     354  !JE        test_day=0 !on remet a zero ttes les 24 h
     355  !JE        print *,'LAST TIME STEP OF DAY ',julien
     356  !JE      ENDIF
     357
     358  jH_day = jH_day + pdtphys / (24. * 3600.)
     359  test_day = test_day + 1
     360  IF (jH_day>(day_resol) / 24.) THEN
     361    print *, 'LAST TIME STEP OF DAY ', julien
     362    test_day = 0
     363    jH_day = jH_init
     364  ENDIF
     365  ! PRINT*,'test_day,test_day1',test_day,test_day1
     366
     367END SUBROUTINE read_newemissions

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/seasalt.f90

    r5103 r5104  
    1 c       This SUBROUTINE estimateis Sea Salt emission fluxes over
    2 c       Oceanic surfaces.
    3 c
    4       SUBROUTINE seasalt(v_10m, u_10m, pct_ocean, lmt_sea_salt)
    5    
    6       USE dimphy
    7       IMPLICIT NONE
    8 c
    9       INCLUDE "dimensions.h"
    10       INCLUDE "chem.h"
    11       INCLUDE "chem_spla.h"
    12       INCLUDE "YOMCST.h"
    13       INCLUDE "YOECUMF.h"
    14 c
    15       INTEGER i, bin                 !local variables
    16       REAL pct_ocean(klon)           !hfraction of Ocean in each grid
    17       REAL v_10m(klon), u_10m(klon)  !V&H components of wind @10 m
    18       REAL w_speed_10m(klon)         !wind speed at 10m from surface
    19       REAL lmt_sea_salt(klon,ss_bins)!sea salt emission flux - mg/m2/s
    20       REAL sea_salt_flux(ss_bins)    !sea salt emission flux per unit wind speed
     1! This SUBROUTINE estimateis Sea Salt emission fluxes over
     2! Oceanic surfaces.
     3!
     4SUBROUTINE seasalt(v_10m, u_10m, pct_ocean, lmt_sea_salt)
    215
    22       REAL wind, ocean
    23 c
    24 c------Sea salt emission fluxes for each size bin calculated
    25 c------based on on parameterisation of Gong et al. (1997).
    26 c------Fluxes of sea salt for each size bin are given in mg/m^2/sec
    27 c------at wind speed of 1 m/s at 10m height (at 80% RH).
    28 c------Fluxes at various wind speeds (@10 m from sea
    29 c------surfaces are estimated using relationship: F=flux*U_10^3.14
    30 c
    31 cnhl for size bin of 0.03-0.5 and 0.5-20
    32       DATA sea_salt_flux/4.5E-09,8.7E-7/
     6  USE dimphy
     7  IMPLICIT NONE
     8  !
     9  INCLUDE "dimensions.h"
     10  INCLUDE "chem.h"
     11  INCLUDE "chem_spla.h"
     12  INCLUDE "YOMCST.h"
     13  INCLUDE "YOECUMF.h"
     14  !
     15  INTEGER :: i, bin                 !local variables
     16  REAL :: pct_ocean(klon)           !hfraction of Ocean in each grid
     17  REAL :: v_10m(klon), u_10m(klon)  !V&H components of wind @10 m
     18  REAL :: w_speed_10m(klon)         !wind speed at 10m from surface
     19  REAL :: lmt_sea_salt(klon, ss_bins)!sea salt emission flux - mg/m2/s
     20  REAL :: sea_salt_flux(ss_bins)    !sea salt emission flux per unit wind speed
    3321
    34       DO i=1, klon
    35       w_speed_10m(i)= (v_10m(i)**2.0+u_10m(i)**2.0)**0.5
    36       ENDDO
    37 c
    38       DO bin=1,ss_bins
    39       wind=0.0
    40       ocean=0.0
    41       DO i=1, klon
    42       lmt_sea_salt(i,bin)=sea_salt_flux(bin)*(w_speed_10m(i)**3.41)
    43      . *pct_ocean(i)*1.e-4*1.e-3                       !g/cm2/s
    44       wind=wind+w_speed_10m(i)
    45       ocean=ocean+pct_ocean(i)
    46       ENDDO
    47 !      print *,'Sea Salt flux = ',sea_salt_flux(bin)
    48       ENDDO
    49 !      print *,'SUM OF WIND = ',wind
    50 !      print *,'SUM OF OCEAN SURFACE = ',ocean
    51       RETURN   
    52       END
     22  REAL :: wind, ocean
     23  !
     24  !------Sea salt emission fluxes for each size bin calculated
     25  !------based on on parameterisation of Gong et al. (1997).
     26  !------Fluxes of sea salt for each size bin are given in mg/m^2/sec
     27  !------at wind speed of 1 m/s at 10m height (at 80% RH).
     28  !------Fluxes at various wind speeds (@10 m from sea
     29  !------surfaces are estimated using relationship: F=flux*U_10^3.14
     30  !
     31  !nhl for size bin of 0.03-0.5 and 0.5-20
     32  DATA sea_salt_flux/4.5E-09, 8.7E-7/
     33
     34  DO i = 1, klon
     35    w_speed_10m(i) = (v_10m(i)**2.0 + u_10m(i)**2.0)**0.5
     36  ENDDO
     37  !
     38  DO bin = 1, ss_bins
     39    wind = 0.0
     40    ocean = 0.0
     41    DO i = 1, klon
     42      lmt_sea_salt(i, bin) = sea_salt_flux(bin) * (w_speed_10m(i)**3.41) &
     43              * pct_ocean(i) * 1.e-4 * 1.e-3                       !g/cm2/s
     44      wind = wind + w_speed_10m(i)
     45      ocean = ocean + pct_ocean(i)
     46    ENDDO
     47    ! print *,'Sea Salt flux = ',sea_salt_flux(bin)
     48  ENDDO
     49  ! print *,'SUM OF WIND = ',wind
     50  ! print *,'SUM OF OCEAN SURFACE = ',ocean
     51  RETURN
     52END SUBROUTINE seasalt

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/sediment_mod.f90

    r5103 r5104  
    1 c----- This SUBROUTINE calculates the sedimentation flux of Tracers
    2 c
    3       SUBROUTINE sediment_mod(t_seri,pplay,zrho,paprs,time_step,RHcl,
    4      .                                       id_coss,id_codu,id_scdu,
    5      .                                        ok_chimeredust,
    6      .                           sed_ss,sed_dust,sed_dustsco,
    7      .                        sed_ss3D,sed_dust3D,sed_dustsco3D,tr_seri)
    8 cnhl     .                                       xlon,xlat,
    9 c
    10        USE dimphy
    11        USE infotrac
    12       IMPLICIT NONE
    13 c
    14       INCLUDE "dimensions.h"
    15       INCLUDE "chem.h"
    16       INCLUDE "YOMCST.h"
    17       INCLUDE "YOECUMF.h"
    18 c
    19        REAL RHcl(klon,klev)     ! humidite relative ciel clair
    20        REAL tr_seri(klon, klev,nbtr) !conc of tracers
    21        REAL sed_ss(klon) !sedimentation flux of Sea Salt (g/m2/s)
    22        REAL sed_dust(klon) !sedimentation flux of dust (g/m2/s)
    23        REAL sed_dustsco(klon) !sedimentation flux of scoarse  dust (g/m2/s)
    24        REAL sed_ss3D(klon,klev) !sedimentation flux of Sea Salt (g/m2/s)
    25        REAL sed_dust3D(klon,klev) !sedimentation flux of dust (g/m2/s)
    26        REAL sed_dustsco3D(klon,klev) !sedimentation flux of scoarse  dust (g/m2/s)
    27        REAL t_seri(klon, klev)   !Temperature at mid points of Z (K)
    28        REAL v_dep_ss(klon,klev)  ! sed. velocity for SS m/s
    29        REAL v_dep_dust(klon,klev)  ! sed. velocity for dust m/s
    30        REAL v_dep_dustsco(klon,klev)  ! sed. velocity for dust m/s
    31        REAL pplay(klon, klev)    !pressure at mid points of Z (Pa)
    32        REAL zrho(klon, klev)     !Density of air at mid points of Z (kg/m3)
    33        REAL paprs(klon, klev+1)    !pressure at interface of layers Z (Pa)
    34        REAL time_step            !time step (sec)
    35        LOGICAL ok_chimeredust
    36        REAL xlat(klon)       ! latitudes pour chaque point
    37        REAL xlon(klon)       ! longitudes pour chaque point
    38        INTEGER id_coss,id_codu,id_scdu
    39 c
    40 c------local variables
    41 c
    42        INTEGER i, k, nbre_RH
    43        PARAMETER(nbre_RH=12)
    44 c
    45        REAL lambda, ss_g           
    46        REAL mmd_ss      !mass median diameter of SS (um)
    47        REAL mmd_dust          !mass median diameter of dust (um)
    48        REAL mmd_dustsco          !mass median diameter of scoarse dust (um)
    49        REAL rho_ss(nbre_RH),rho_ss1 !density of sea salt (kg/m3)
    50        REAL rho_dust          !density of dust(kg/m3)
    51        REAL v_stokes, CC, v_sed, ss_growth_f(nbre_RH)
    52        REAL sed_flux(klon,klev)  ! sedimentation flux g/m2/s
    53        REAL air_visco(klon,klev)
    54        REAL zdz(klon,klev)       ! layers height (m)
    55        REAL temp                 ! temperature in degree Celius
    56 c
    57        INTEGER RH_num
    58        REAL RH_MAX, DELTA, rh, RH_tab(nbre_RH)
    59        PARAMETER (RH_MAX=95.)
    60 c
    61        DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
    62 c
    63 c
    64        DATA rho_ss/2160. ,2160. ,2160.,  2160,  1451.6, 1367.9,
    65      .             1302.9,1243.2,1182.7, 1149.5,1111.6, 1063.1/
    66 c
    67        DATA ss_growth_f/0.503, 0.503, 0.503, 0.503, 0.724, 0.782,
    68      .                  0.838, 0.905, 1.000, 1.072, 1.188, 1.447/
    69 c
    70 c
    71        mmd_ss=12.7   !dia -um at 80% for bin 0.5-20 um but 90% of real mmd
    72 !               obsolete      mmd_dust=2.8  !micrometer for bin 0.5-20 and 0.5-10 um
    73 ! 4tracer SPLA:       mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
    74 !3days       mmd_dust=3.333464  !micrometer for bin 0.5-20 and 0.5-10 um
    75 !3days       mmd_dustsco=12.91315  !micrometer for bin 0.5-20 and 0.5-10 um
    76 !JE20140911       mmd_dust=3.002283  !micrometer for bin 0.5-20 and 0.5-10 um
    77 !JE20140911       mmd_dustsco=13.09771  !micrometer for bin 0.5-20 and 0.5-10 um
    78 !JE20140911        mmd_dust=5.156346  !micrometer for bin 0.5-20 and 0.5-10 um
    79 !JE20140911        mmd_dustsco=15.56554  !micrometer for bin 0.5-20 and 0.5-10 um
    80         IF (ok_chimeredust) THEN
    81 !JE20150212<< : changes in ustar in dustmod changes emission distribution
    82 !        mmd_dust=3.761212  !micrometer for bin 0.5-3 and 0.5-10 um
    83 !        mmd_dustsco=15.06167  !micrometer for bin 3-20 and 0.5-10 um
    84 !JE20150212>>
    85 !JE20150618: Change in div3 of dustmod changes distribution. now is div3=6
    86 !div=3        mmd_dust=3.983763
    87 !div=3        mmd_dustsco=15.10854
    88         mmd_dust=3.898047
    89         mmd_dustsco=15.06167
    90         ELSE
    91         mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
    92         mmd_dustsco=100. ! absurd value, bin not used in this scheme
     1!----- This SUBROUTINE calculates the sedimentation flux of Tracers
     2!
     3SUBROUTINE sediment_mod(t_seri, pplay, zrho, paprs, time_step, RHcl, &
     4        id_coss, id_codu, id_scdu, &
     5        ok_chimeredust, &
     6        sed_ss, sed_dust, sed_dustsco, &
     7        sed_ss3D, sed_dust3D, sed_dustsco3D, tr_seri)
     8  !nhl     .                                       xlon,xlat,
     9  !
     10  USE dimphy
     11  USE infotrac
     12  IMPLICIT NONE
     13  !
     14  INCLUDE "dimensions.h"
     15  INCLUDE "chem.h"
     16  INCLUDE "YOMCST.h"
     17  INCLUDE "YOECUMF.h"
     18  !
     19  REAL :: RHcl(klon, klev)     ! humidite relative ciel clair
     20  REAL :: tr_seri(klon, klev, nbtr) !conc of tracers
     21  REAL :: sed_ss(klon) !sedimentation flux of Sea Salt (g/m2/s)
     22  REAL :: sed_dust(klon) !sedimentation flux of dust (g/m2/s)
     23  REAL :: sed_dustsco(klon) !sedimentation flux of scoarse  dust (g/m2/s)
     24  REAL :: sed_ss3D(klon, klev) !sedimentation flux of Sea Salt (g/m2/s)
     25  REAL :: sed_dust3D(klon, klev) !sedimentation flux of dust (g/m2/s)
     26  REAL :: sed_dustsco3D(klon, klev) !sedimentation flux of scoarse  dust (g/m2/s)
     27  REAL :: t_seri(klon, klev)   !Temperature at mid points of Z (K)
     28  REAL :: v_dep_ss(klon, klev)  ! sed. velocity for SS m/s
     29  REAL :: v_dep_dust(klon, klev)  ! sed. velocity for dust m/s
     30  REAL :: v_dep_dustsco(klon, klev)  ! sed. velocity for dust m/s
     31  REAL :: pplay(klon, klev)    !pressure at mid points of Z (Pa)
     32  REAL :: zrho(klon, klev)     !Density of air at mid points of Z (kg/m3)
     33  REAL :: paprs(klon, klev + 1)    !pressure at interface of layers Z (Pa)
     34  REAL :: time_step            !time step (sec)
     35  LOGICAL :: ok_chimeredust
     36  REAL :: xlat(klon)       ! latitudes pour chaque point
     37  REAL :: xlon(klon)       ! longitudes pour chaque point
     38  INTEGER :: id_coss, id_codu, id_scdu
     39  !
     40  !------local variables
     41  !
     42  INTEGER :: i, k, nbre_RH
     43  PARAMETER(nbre_RH = 12)
     44  !
     45  REAL :: lambda, ss_g
     46  REAL :: mmd_ss      !mass median diameter of SS (um)
     47  REAL :: mmd_dust          !mass median diameter of dust (um)
     48  REAL :: mmd_dustsco          !mass median diameter of scoarse dust (um)
     49  REAL :: rho_ss(nbre_RH), rho_ss1 !density of sea salt (kg/m3)
     50  REAL :: rho_dust          !density of dust(kg/m3)
     51  REAL :: v_stokes, CC, v_sed, ss_growth_f(nbre_RH)
     52  REAL :: sed_flux(klon, klev)  ! sedimentation flux g/m2/s
     53  REAL :: air_visco(klon, klev)
     54  REAL :: zdz(klon, klev)       ! layers height (m)
     55  REAL :: temp                 ! temperature in degree Celius
     56  !
     57  INTEGER :: RH_num
     58  REAL :: RH_MAX, DELTA, rh, RH_tab(nbre_RH)
     59  PARAMETER (RH_MAX = 95.)
     60  !
     61  DATA RH_tab/0., 10., 20., 30., 40., 50., 60., 70., 80., 85., 90., 95./
     62  !
     63  !
     64  DATA rho_ss/2160., 2160., 2160., 2160, 1451.6, 1367.9, &
     65          1302.9, 1243.2, 1182.7, 1149.5, 1111.6, 1063.1/
     66  !
     67  DATA ss_growth_f/0.503, 0.503, 0.503, 0.503, 0.724, 0.782, &
     68          0.838, 0.905, 1.000, 1.072, 1.188, 1.447/
     69  !
     70  !
     71  mmd_ss = 12.7   !dia -um at 80% for bin 0.5-20 um but 90% of real mmd
     72  ! obsolete      mmd_dust=2.8  !micrometer for bin 0.5-20 and 0.5-10 um
     73  ! 4tracer SPLA:       mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
     74  !3days       mmd_dust=3.333464  !micrometer for bin 0.5-20 and 0.5-10 um
     75  !3days       mmd_dustsco=12.91315  !micrometer for bin 0.5-20 and 0.5-10 um
     76  !JE20140911       mmd_dust=3.002283  !micrometer for bin 0.5-20 and 0.5-10 um
     77  !JE20140911       mmd_dustsco=13.09771  !micrometer for bin 0.5-20 and 0.5-10 um
     78  !JE20140911        mmd_dust=5.156346  !micrometer for bin 0.5-20 and 0.5-10 um
     79  !JE20140911        mmd_dustsco=15.56554  !micrometer for bin 0.5-20 and 0.5-10 um
     80  IF (ok_chimeredust) THEN
     81    !JE20150212<< : changes in ustar in dustmod changes emission distribution
     82    ! mmd_dust=3.761212  !micrometer for bin 0.5-3 and 0.5-10 um
     83    ! mmd_dustsco=15.06167  !micrometer for bin 3-20 and 0.5-10 um
     84    !JE20150212>>
     85    !JE20150618: Change in div3 of dustmod changes distribution. now is div3=6
     86    !div=3        mmd_dust=3.983763
     87    !div=3        mmd_dustsco=15.10854
     88    mmd_dust = 3.898047
     89    mmd_dustsco = 15.06167
     90  ELSE
     91    mmd_dust = 11.0  !micrometer for bin 0.5-20 and 0.5-10 um
     92    mmd_dustsco = 100. ! absurd value, bin not used in this scheme
     93  ENDIF
     94
     95  rho_dust = 2600. !kg/m3
     96  !
     97  !--------- Air viscosity (poise=0.1 kg/m-sec)-----------
     98  !
     99  DO k = 1, klev
     100    DO i = 1, klon
     101      !
     102      zdz(i, k) = (paprs(i, k) - paprs(i, k + 1)) / zrho(i, k) / RG
     103      !
     104      temp = t_seri(i, k) - RTT
     105      !
     106      IF (temp<0.) THEN
     107        air_visco(i, k) = (1.718 + 0.0049 * temp - 1.2e-5 * temp * temp) * 1.e-4
     108      ELSE
     109        air_visco(i, k) = (1.718 + 0.0049 * temp) * 1.e-4
     110      ENDIF
     111      !
     112    ENDDO
     113  ENDDO
     114  !
     115  !--------- for Sea Salt -------------------
     116  !
     117  !
     118  !
     119  IF(id_coss>0) THEN
     120    DO k = 1, klev
     121      DO i = 1, klon
     122        !
     123        !---cal. correction factor hygroscopic growth of aerosols
     124        !
     125        rh = MIN(RHcl(i, k) * 100., RH_MAX)
     126        RH_num = INT(rh / 10. + 1.)
     127        IF (rh>85.) RH_num = 10
     128        IF (rh>90.) RH_num = 11
     129        DELTA = (rh - RH_tab(RH_num)) / (RH_tab(RH_num + 1) - RH_tab(RH_num))
     130        !
     131        ss_g = ss_growth_f(rh_num) + &
     132                DELTA * (ss_growth_f(RH_num + 1) - ss_growth_f(RH_num))
     133
     134        rho_ss1 = rho_ss(rh_num) + &
     135                DELTA * (rho_ss(RH_num + 1) - rho_ss(RH_num))
     136        !
     137        v_stokes = RG * (rho_ss1 - zrho(i, k)) * & !m/sec
     138                (mmd_ss * ss_g) * (mmd_ss * ss_g) * &
     139                1.e-12 / (18.0 * air_visco(i, k) / 10.)
     140        !
     141        lambda = 6.6 * 1.e-8 * (103125 / pplay(i, k)) * (t_seri(i, k) / 293.15)
     142        !
     143        CC = 1.0 + 1.257 * lambda / (mmd_ss * ss_g) / 1.e6  ! C-correction factor
     144        !
     145        v_sed = v_stokes * CC                       ! m/sec !orig
     146        !
     147        !---------check for v_sed*dt<zdz
     148        !
     149        IF (v_sed * time_step>zdz(i, k)) THEN
     150          v_sed = zdz(i, k) / time_step
    93151        ENDIF
    94 
    95 
    96        rho_dust=2600. !kg/m3
    97 c
    98 c--------- Air viscosity (poise=0.1 kg/m-sec)-----------
    99 c
    100        DO k=1, klev
    101        DO i=1, klon
    102 c
    103        zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
    104 c
    105        temp=t_seri(i,k)-RTT
    106 c
    107        IF (temp<0.) THEN
    108          air_visco(i,k)=(1.718+0.0049*temp-1.2e-5*temp*temp)*1.e-4
    109        ELSE
    110          air_visco(i,k)=(1.718+0.0049*temp)*1.e-4
    111        ENDIF
    112 c
    113        ENDDO
    114        ENDDO
    115 c
    116 c--------- for Sea Salt -------------------
    117 c
    118 c
    119 c
    120        IF(id_coss>0) THEN
    121        DO k=1, klev
    122        DO i=1,klon
    123 c
    124 c---cal. correction factor hygroscopic growth of aerosols
    125 c
    126         rh=MIN(RHcl(i,k)*100.,RH_MAX)
    127         RH_num = INT( rh/10. + 1.)
    128         IF (rh>85.) RH_num=10
    129         IF (rh>90.) RH_num=11
    130         DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
    131 c
    132         ss_g=ss_growth_f(rh_num) +
    133      .       DELTA*(ss_growth_f(RH_num+1)-ss_growth_f(RH_num))
    134 
    135         rho_ss1=rho_ss(rh_num) +
    136      .       DELTA*(rho_ss(RH_num+1)-rho_ss(RH_num))             
    137 c
    138         v_stokes=RG*(rho_ss1-zrho(i,k))*      !m/sec
    139      .           (mmd_ss*ss_g)*(mmd_ss*ss_g)*
    140      .           1.e-12/(18.0*air_visco(i,k)/10.)
    141 c
    142        lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
    143 c
    144        CC=1.0+1.257*lambda/(mmd_ss*ss_g)/1.e6  ! C-correction factor
    145 c
    146        v_sed=v_stokes*CC                       ! m/sec !orig
    147 c
    148 c---------check for v_sed*dt<zdz
    149 c
    150        IF (v_sed*time_step>zdz(i,k)) THEN
    151          v_sed=zdz(i,k)/time_step     
    152        ENDIF
    153 c
    154        v_dep_ss(i,k)= v_sed
    155        sed_flux(i,k)= tr_seri(i,k,id_coss)*v_sed !g/cm3*m/sec
    156        !sed_ss3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
    157       ! conc_sed_ss3D(i,k)=sed_flux(i,k)*1.e6      !g/m3*sec !!!!!!!
    158 c
    159        ENDDO          !klon
    160        ENDDO          !klev
    161 c
    162 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    163        sed_ss3D(:,:)=0.0  ! initialisation
    164      
    165        DO k=1, klev
    166        DO i=1, klon
    167        sed_ss3D(i,k)=sed_ss3D(i,k)-
    168      .        sed_flux(i,k)/zdz(i,k) !!!!!!!!!!!!!!!!!!!!!!
    169        ENDDO          !klon
    170        ENDDO          !klev
    171 c
    172        DO k=1, klev-1
    173        DO i=1, klon
    174         sed_ss3D(i,k)=sed_ss3D(i,k)+                   
    175      .                  sed_flux(i,k+1)/zdz(i,k) !!!!!!!!
    176 
    177        ENDDO          !klon
    178        ENDDO          !klev
    179 
    180       DO k = 1, klev
    181       DO i = 1, klon
    182           tr_seri(i,k,id_coss)=tr_seri(i,k,id_coss)+
    183      s   sed_ss3D(i,k)*time_step
     152        !
     153        v_dep_ss(i, k) = v_sed
     154        sed_flux(i, k) = tr_seri(i, k, id_coss) * v_sed !g/cm3*m/sec
     155        ! !sed_ss3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
     156        ! ! conc_sed_ss3D(i,k)=sed_flux(i,k)*1.e6      !g/m3*sec !!!!!!!
     157        !
     158      ENDDO          !klon
     159    ENDDO          !klev
     160    !
     161    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     162    sed_ss3D(:, :) = 0.0  ! initialisation
     163
     164    DO k = 1, klev
     165      DO i = 1, klon
     166        sed_ss3D(i, k) = sed_ss3D(i, k) - &
     167                sed_flux(i, k) / zdz(i, k) !!!!!!!!!!!!!!!!!!!!!!
     168      ENDDO          !klon
     169    ENDDO          !klev
     170    !
     171    DO k = 1, klev - 1
     172      DO i = 1, klon
     173        sed_ss3D(i, k) = sed_ss3D(i, k) + &
     174                sed_flux(i, k + 1) / zdz(i, k) !!!!!!!!
     175
     176      ENDDO          !klon
     177    ENDDO          !klev
     178
     179    DO k = 1, klev
     180      DO i = 1, klon
     181        tr_seri(i, k, id_coss) = tr_seri(i, k, id_coss) + &
     182                sed_ss3D(i, k) * time_step
    184183      ENDDO
     184    ENDDO
     185
     186    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     187    !
     188    DO i = 1, klon
     189      sed_ss(i) = sed_flux(i, 1) * 1.e6 * 1.e3    !--unit mg/m2/s
     190    ENDDO          !klon
     191  ELSE
     192    DO i = 1, klon
     193      sed_ss(i) = 0.
     194    ENDDO
     195  ENDIF
     196  !
     197  !
     198
     199  !--------- For dust ------------------
     200  !
     201  !
     202  IF(id_codu>0) THEN
     203    DO k = 1, klev
     204      DO i = 1, klon
     205        !
     206        v_stokes = RG * (rho_dust - zrho(i, k)) * & !m/sec
     207                mmd_dust * mmd_dust * &
     208                1.e-12 / (18.0 * air_visco(i, k) / 10.)
     209        !
     210        lambda = 6.6 * 1.e-8 * (103125 / pplay(i, k)) * (t_seri(i, k) / 293.15)
     211        CC = 1.0 + 1.257 * lambda / (mmd_dust) / 1.e6        !dimensionless
     212        v_sed = v_stokes * CC                       !m/sec
     213        !
     214        !---------check for v_sed*dt<zdz
     215        !
     216        IF (v_sed * time_step>zdz(i, k)) THEN
     217          v_sed = zdz(i, k) / time_step
     218        ENDIF
     219
     220        !
     221        v_dep_dust(i, k) = v_sed
     222        sed_flux(i, k) = tr_seri(i, k, id_codu) * v_sed !g/cm3.m/sec
     223        ! !sed_dust3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
     224        !
     225      ENDDO          !klon
     226    ENDDO          !klev
     227
     228    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     229    sed_dust3D(:, :) = 0.0  ! initialisation
     230
     231    DO k = 1, klev
     232      DO i = 1, klon
     233        sed_dust3D(i, k) = sed_dust3D(i, k) - &
     234                sed_flux(i, k) / zdz(i, k)
     235      ENDDO          !klon
     236    ENDDO          !klev
     237
     238    !
     239    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     240
     241    DO k = 1, klev - 1
     242      DO i = 1, klon
     243        sed_dust3D(i, k) = sed_dust3D(i, k) + &
     244                sed_flux(i, k + 1) / zdz(i, k)
     245      ENDDO          !klon
     246    ENDDO          !klev
     247    !
     248    DO k = 1, klev
     249      DO i = 1, klon
     250        tr_seri(i, k, id_codu) = tr_seri(i, k, id_codu) + &
     251                sed_dust3D(i, k) * time_step
    185252      ENDDO
    186 
    187 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    188 c
    189        DO i=1, klon
    190          sed_ss(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
    191        ENDDO          !klon
    192        ELSE
    193         DO i=1, klon
    194           sed_ss(i)=0.
    195         ENDDO
    196        ENDIF
    197 c
    198 c
    199 
    200 c--------- For dust ------------------
    201 c
    202 c
    203        IF(id_codu>0) THEN
    204        DO k=1, klev
    205        DO i=1,klon
    206 c
    207         v_stokes=RG*(rho_dust-zrho(i,k))*      !m/sec
    208      .           mmd_dust*mmd_dust*
    209      .           1.e-12/(18.0*air_visco(i,k)/10.)
    210 c
    211        lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
    212        CC=1.0+1.257*lambda/(mmd_dust)/1.e6        !dimensionless
    213        v_sed=v_stokes*CC                       !m/sec
    214 c
    215 c---------check for v_sed*dt<zdz
    216 c
    217        IF (v_sed*time_step>zdz(i,k)) THEN
    218          v_sed=zdz(i,k)/time_step     
    219        ENDIF
    220 
    221 c
    222        v_dep_dust(i,k)= v_sed
    223        sed_flux(i,k)  = tr_seri(i,k,id_codu)*v_sed !g/cm3.m/sec
    224        !sed_dust3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
    225 c
    226        ENDDO          !klon
    227        ENDDO          !klev
    228 
    229 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    230        sed_dust3D(:,:)=0.0  ! initialisation
    231 
    232        DO k=1, klev
    233        DO i=1, klon
    234        sed_dust3D(i,k)=sed_dust3D(i,k)-
    235      .                  sed_flux(i,k)/zdz(i,k)
    236        ENDDO          !klon
    237        ENDDO          !klev
    238 
    239 c
    240 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    241        
    242        DO k=1, klev-1
    243        DO i=1, klon
    244         sed_dust3D(i,k)=sed_dust3D(i,k) +
    245      .                  sed_flux(i,k+1)/zdz(i,k)
    246        ENDDO          !klon
    247        ENDDO          !klev
    248 c
    249       DO k = 1, klev
    250       DO i = 1, klon
    251          tr_seri(i,k,id_codu)=tr_seri(i,k,id_codu)+
    252      s    sed_dust3D(i,k)*time_step
     253    ENDDO
     254
     255    DO i = 1, klon
     256      sed_dust(i) = sed_flux(i, 1) * 1.e6 * 1.e3    !--unit mg/m2/s
     257    ENDDO          !klon
     258  ELSE
     259    DO i = 1, klon
     260      sed_dust(i) = 0.
     261    ENDDO
     262  ENDIF
     263  !
     264
     265
     266  !--------- For scoarse  dust ------------------
     267  !
     268  !
     269  IF(id_scdu>0) THEN
     270    DO k = 1, klev
     271      DO i = 1, klon
     272        !
     273        v_stokes = RG * (rho_dust - zrho(i, k)) * & !m/sec
     274                mmd_dustsco * mmd_dustsco * &
     275                1.e-12 / (18.0 * air_visco(i, k) / 10.)
     276        !
     277        lambda = 6.6 * 1.e-8 * (103125 / pplay(i, k)) * (t_seri(i, k) / 293.15)
     278        CC = 1.0 + 1.257 * lambda / (mmd_dustsco) / 1.e6        !dimensionless
     279        v_sed = v_stokes * CC                       !m/sec
     280        !
     281        !---------check for v_sed*dt<zdz
     282
     283        IF (v_sed * time_step>zdz(i, k)) THEN
     284          v_sed = zdz(i, k) / time_step
     285        ENDIF
     286
     287        !
     288        v_dep_dustsco(i, k) = v_sed
     289        sed_flux(i, k) = tr_seri(i, k, id_scdu) * v_sed !g/cm3.m/sec
     290        ! !sed_dustsco3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
     291        !
     292      ENDDO          !klon
     293    ENDDO          !klev
     294
     295    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     296    sed_dustsco3D(:, :) = 0.0  ! initialisation
     297
     298    DO k = 1, klev
     299      DO i = 1, klon
     300        sed_dustsco3D(i, k) = sed_dustsco3D(i, k) - &
     301                sed_flux(i, k) / zdz(i, k)
     302      ENDDO          !klon
     303    ENDDO          !klev
     304    !
     305    DO k = 1, klev - 1
     306      DO i = 1, klon
     307        sed_dustsco3D(i, k) = sed_dustsco3D(i, k) + &
     308                sed_flux(i, k + 1) / zdz(i, k)
     309      ENDDO          !klon
     310    ENDDO          !klev
     311
     312    DO k = 1, klev
     313      DO i = 1, klon
     314        tr_seri(i, k, id_scdu) = tr_seri(i, k, id_scdu) + &
     315                sed_dustsco3D(i, k) * time_step
    253316      ENDDO
    254       ENDDO
    255 
    256 
    257        DO i=1, klon
    258          sed_dust(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
    259        ENDDO          !klon
    260        ELSE
    261         DO i=1, klon
    262           sed_dust(i)=0.
    263         ENDDO
    264        ENDIF
    265 c
    266 
    267 
    268 c--------- For scoarse  dust ------------------
    269 c
    270 c
    271        IF(id_scdu>0) THEN
    272        DO k=1, klev
    273        DO i=1,klon
    274 c
    275         v_stokes=RG*(rho_dust-zrho(i,k))*      !m/sec
    276      .           mmd_dustsco*mmd_dustsco*
    277      .           1.e-12/(18.0*air_visco(i,k)/10.)
    278 c
    279        lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
    280        CC=1.0+1.257*lambda/(mmd_dustsco)/1.e6        !dimensionless
    281        v_sed=v_stokes*CC                       !m/sec
    282 c
    283 c---------check for v_sed*dt<zdz
    284 
    285 
    286        IF (v_sed*time_step>zdz(i,k)) THEN
    287          v_sed=zdz(i,k)/time_step
    288        ENDIF
    289 
    290 c
    291        v_dep_dustsco(i,k)= v_sed
    292        sed_flux(i,k)     = tr_seri(i,k,id_scdu)*v_sed !g/cm3.m/sec
    293        !sed_dustsco3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
    294 c
    295        ENDDO          !klon
    296        ENDDO          !klev
    297 
    298 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    299        sed_dustsco3D(:,:)=0.0  ! initialisation
    300 
    301        DO k=1, klev
    302        DO i=1, klon
    303        sed_dustsco3D(i,k)=sed_dustsco3D(i,k)-
    304      .                  sed_flux(i,k)/zdz(i,k)
    305        ENDDO          !klon
    306        ENDDO          !klev
    307 c
    308        DO k=1, klev-1
    309        DO i=1, klon
    310         sed_dustsco3D(i,k)=sed_dustsco3D(i,k) +
    311      .                  sed_flux(i,k+1)/zdz(i,k)
    312        ENDDO          !klon
    313        ENDDO          !klev
    314 
    315       DO k = 1, klev
    316       DO i = 1, klon
    317        tr_seri(i,k,id_scdu)=tr_seri(i,k,id_scdu)+
    318      s  sed_dustsco3D(i,k)*time_step
    319       ENDDO
    320       ENDDO
    321 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    322 
    323 
    324 c
    325        DO i=1, klon
    326          sed_dustsco(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
    327        ENDDO          !klon
    328        ELSE
    329         DO i=1, klon
    330           sed_dustsco(i)=0.
    331         ENDDO
    332        ENDIF
    333 c
    334 
    335 
    336 
    337 
    338 c
    339        RETURN
    340        END
     317    ENDDO
     318    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     319
     320
     321    !
     322    DO i = 1, klon
     323      sed_dustsco(i) = sed_flux(i, 1) * 1.e6 * 1.e3    !--unit mg/m2/s
     324    ENDDO          !klon
     325  ELSE
     326    DO i = 1, klon
     327      sed_dustsco(i) = 0.
     328    ENDDO
     329  ENDIF
     330  !
     331
     332
     333
     334
     335  !
     336  RETURN
     337END SUBROUTINE sediment_mod

  • LMDZ6/branches/Amaury_dev/libf/phylmd/Dust/trconvect.f90

    r5103 r5104  
    1 c Subroutine that computes the convective mixing and transport
    2       SUBROUTINE trconvect(pplay,t_seri,pdtphys,pmfu,pmfd,pen_u,pde_u,
    3      .          pen_d,pde_d,paprs,zdz,xconv,qmin,qmax,lminmax,masse,
    4      .                                                dtrconv,tr_seri)
     1! Subroutine that computes the convective mixing and transport
     2SUBROUTINE trconvect(pplay, t_seri, pdtphys, pmfu, pmfd, pen_u, pde_u, &
     3        pen_d, pde_d, paprs, zdz, xconv, qmin, qmax, lminmax, masse, &
     4        dtrconv, tr_seri)
    55
    6       USE dimphy
    7       USE infotrac
    8       USE indice_sol_mod
     6  USE dimphy
     7  USE infotrac
     8  USE indice_sol_mod
    99
    10       IMPLICIT NONE
     10  IMPLICIT NONE
    1111
    12       INCLUDE "dimensions.h"
    13       INCLUDE "chem.h"
    14       INCLUDE "YOMCST.h"
    15       INCLUDE "paramet.h"
     12  INCLUDE "dimensions.h"
     13  INCLUDE "chem.h"
     14  INCLUDE "YOMCST.h"
     15  INCLUDE "paramet.h"
    1616
    17 c============================= INPUT ===================================
    18       REAL qmin, qmax
    19       REAL xconv(nbtr), masse(nbtr)
    20       REAL pplay(klon,klev)    ! pression pour le mileu de chaque couche (en Pa)
    21       REAL t_seri(klon,klev)   ! temperature       
    22       REAL zdz(klon,klev)      ! zdz
    23       REAL paprs(klon,klev+1)  ! pression pour chaque inter-couche (en Pa)
    24       REAL pmfu(klon,klev)     ! flux de masse dans le panache montant
    25       REAL pmfd(klon,klev)     ! flux de masse dans le panache descendant
    26       REAL pen_u(klon,klev)    ! flux entraine dans le panache montant
    27       REAL pde_u(klon,klev)    ! flux detraine dans le panache montant
    28       REAL pen_d(klon,klev)    ! flux entraine dans le panache descendant
    29       REAL pde_d(klon,klev)    ! flux detraine dans le panache descendant 
    30       LOGICAL lminmax
    31       REAL pdtphys
    32 c============================= OUTPUT ==================================
    33       REAL aux_var1(klon,klev)
    34       REAL aux_var2(klon,klev)
    35       REAL tr_seri(klon,klev,nbtr) ! traceur
    36       REAL dtrconv(klon,nbtr) ! traceur
    37 c========================= LOCAL VARIABLES =============================
    38       INTEGER it, k, i, j
    39       REAL d_tr(klon,klev,nbtr)
     17  !============================= INPUT ===================================
     18  REAL :: qmin, qmax
     19  REAL :: xconv(nbtr), masse(nbtr)
     20  REAL :: pplay(klon, klev)    ! pression pour le mileu de chaque couche (en Pa)
     21  REAL :: t_seri(klon, klev)   ! temperature
     22  REAL :: zdz(klon, klev)      ! zdz
     23  REAL :: paprs(klon, klev + 1)  ! pression pour chaque inter-couche (en Pa)
     24  REAL :: pmfu(klon, klev)     ! flux de masse dans le panache montant
     25  REAL :: pmfd(klon, klev)     ! flux de masse dans le panache descendant
     26  REAL :: pen_u(klon, klev)    ! flux entraine dans le panache montant
     27  REAL :: pde_u(klon, klev)    ! flux detraine dans le panache montant
     28  REAL :: pen_d(klon, klev)    ! flux entraine dans le panache descendant
     29  REAL :: pde_d(klon, klev)    ! flux detraine dans le panache descendant
     30  LOGICAL :: lminmax
     31  REAL :: pdtphys
     32  !============================= OUTPUT ==================================
     33  REAL :: aux_var1(klon, klev)
     34  REAL :: aux_var2(klon, klev)
     35  REAL :: tr_seri(klon, klev, nbtr) ! traceur
     36  REAL :: dtrconv(klon, nbtr) ! traceur
     37  !========================= LOCAL VARIABLES =============================
     38  INTEGER :: it, k, i, j
     39  REAL :: d_tr(klon, klev, nbtr)
    4040
    41       EXTERNAL nflxtr, tiedqneg, minmaxqfi
    42      
    43       DO it=1, nbtr
    44 c
    45       DO i=1, klon
    46         dtrconv(i,it)=0.0
     41  EXTERNAL nflxtr, tiedqneg, minmaxqfi
     42
     43  DO it = 1, nbtr
     44    !
     45    DO i = 1, klon
     46      dtrconv(i, it) = 0.0
     47    ENDDO
     48    DO i = 1, klon
     49      DO j = 1, klev
     50        aux_var1(i, j) = tr_seri(i, j, it)
     51        aux_var2(i, j) = d_tr(i, j, it)
    4752      ENDDO
    48       DO i=1,klon
    49       DO j=1,klev
    50         aux_var1(i,j)=tr_seri(i,j,it)
    51         aux_var2(i,j)=d_tr(i,j,it)
     53    ENDDO
     54
     55    !
     56    !nhl      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
     57    !nhl     .            pplay, paprs, tr_seri(1,1,it), d_tr(1,1,it) )
     58    CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
     59            pplay, paprs, aux_var1, aux_var2)
     60    !
     61    CALL tiedqneg(paprs, aux_var1, aux_var2)
     62    !nhl      CALL tiedqneg(paprs,tr_seri(1,1,it), d_tr(1,1,it))
     63    DO i = 1, klon
     64      DO j = 1, klev
     65        tr_seri(i, j, it) = aux_var1(i, j)
     66        d_tr(i, j, it) = aux_var2(i, j)
    5267      ENDDO
    53       ENDDO
    54                                                  
    55 c
    56 cnhl      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
    57 cnhl     .            pplay, paprs, tr_seri(1,1,it), d_tr(1,1,it) )
    58       CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
    59      .            pplay, paprs, aux_var1, aux_var2 )
    60 c
    61       CALL tiedqneg(paprs,aux_var1, aux_var2)
    62 cnhl      CALL tiedqneg(paprs,tr_seri(1,1,it), d_tr(1,1,it))
    63       DO i=1,klon
    64       DO j=1,klev
    65         tr_seri(i,j,it)=aux_var1(i,j)
    66         d_tr(i,j,it)=aux_var2(i,j)
    67       ENDDO
    68       ENDDO
    69 c
    70       DO k = 1, klev
     68    ENDDO
     69    !
     70    DO k = 1, klev
    7171      DO i = 1, klon
    72         IF (d_tr(i,k,it)<0.) THEN
    73           tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr(i,k,it)
     72        IF (d_tr(i, k, it)<0.) THEN
     73          tr_seri(i, k, it) = tr_seri(i, k, it) + d_tr(i, k, it)
    7474        ELSE
    75           tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr(i,k,it)*xconv(it)
     75          tr_seri(i, k, it) = tr_seri(i, k, it) + d_tr(i, k, it) * xconv(it)
    7676        ENDIF
    7777      ENDDO
     78    ENDDO
     79    !
     80    !nhl      CALL kg_to_cm3(pplay,t_seri,d_tr(1,1,it))
     81    CALL kg_to_cm3(pplay, t_seri, aux_var2)
     82    DO i = 1, klon
     83      DO j = 1, klev
     84        d_tr(i, j, it) = aux_var2(i, j)
    7885      ENDDO
    79 c
    80 cnhl      CALL kg_to_cm3(pplay,t_seri,d_tr(1,1,it))
    81       CALL kg_to_cm3(pplay,t_seri,aux_var2)
    82       DO i=1,klon
    83       DO j=1,klev
    84         d_tr(i,j,it)=aux_var2(i,j)
    85       ENDDO
    86       ENDDO
     86    ENDDO
    8787
    88       DO k = 1, klev
     88    DO k = 1, klev
    8989      DO i = 1, klon
    90         IF (d_tr(i,k,it)>=0.) THEN
    91         dtrconv(i,it)=dtrconv(i,it)+(1.-xconv(it))*d_tr(i,k,it)
    92      .                /RNAVO*masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys
     90        IF (d_tr(i, k, it)>=0.) THEN
     91          dtrconv(i, it) = dtrconv(i, it) + (1. - xconv(it)) * d_tr(i, k, it) &
     92                  / RNAVO * masse(it) * 1.e3 * 1.e6 * zdz(i, k) / pdtphys
    9393        ENDIF
    9494      ENDDO
     95    ENDDO
     96
     97    IF (lminmax) THEN
     98      DO i = 1, klon
     99        DO j = 1, klev
     100          aux_var1(i, j) = tr_seri(i, j, it)
     101        ENDDO
    95102      ENDDO
     103      CALL minmaxqfi(aux_var1, qmin, qmax, 'apr convection')
     104      !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'apr convection')
     105      DO i = 1, klon
     106        DO j = 1, klev
     107          tr_seri(i, j, it) = aux_var1(i, j)
     108        ENDDO
     109      ENDDO
     110    ENDIF
     111    !
     112  ENDDO
    96113
    97       IF (lminmax) THEN
    98         DO i=1,klon
    99         DO j=1,klev
    100           aux_var1(i,j)=tr_seri(i,j,it)
    101         ENDDO
    102         ENDDO
    103         CALL minmaxqfi(aux_var1,qmin,qmax,'apr convection')
    104 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'apr convection')
    105         DO i=1,klon
    106         DO j=1,klev
    107           tr_seri(i,j,it)=aux_var1(i,j)
    108         ENDDO
    109         ENDDO
    110       ENDIF
    111 c
    112       ENDDO
    113 
    114       END
     114END SUBROUTINE trconvect
Note: See TracChangeset for help on using the changeset viewer.