Changeset 5246 for LMDZ6/trunk/libf/phylmd/Dust

LMDZ6/trunk/libf/phylmd/Dust/aeropt_spl.f90

-                      r5245
+                      r5246
+      SUBROUTINE aeropt_spl(zdz, tr_seri, RHcl,
      .              id_prec, id_fine, id_coss, id_codu, id_scdu,
      .              ok_chimeredust,
      .                      ztaue550,ztaue670,ztaue865,
      .                      taue550_tr2,taue670_tr2,taue865_tr2,
      .                      taue550_ss,taue670_ss,taue865_ss,
      .                      taue550_dust,taue670_dust,taue865_dust,
      .             taue550_dustsco,taue670_dustsco,taue865_dustsco)
+c
       USE dimphy
       USE infotrac
       IMPLICIT none
+c
       INCLUDE "chem.h"
       INCLUDE "dimensions.h"
 cINCLUDE "dimphy.h"
       INCLUDE "YOMCST.h"
+c
 c Arguments:
+c
+c======================== INPUT ==================================
       REAL zdz(klon,klev)
       REAL tr_seri(klon,klev,nbtr) ! masse of tracer
       REAL RHcl(klon,klev)     ! humidite relativen ciel clair
       INTEGER  id_prec, id_fine, id_coss, id_codu, id_scdu
       LOGICAL ok_chimeredust
 c============================== OUTPUT =================================
       REAL ztaue550(klon) ! epaisseur optique aerosol 550 nm
       REAL ztaue670(klon) ! epaisseur optique aerosol 670 nm
       REAL ztaue865(klon) ! epaisseur optique aerosol 865 nm
       REAL taue550_tr2(klon) ! epaisseur optique aerosol 550 nm, diagnostic
       REAL taue670_tr2(klon) ! epaisseur optique aerosol 670 nm, diagnostic
       REAL taue865_tr2(klon) ! epaisseur optique aerosol 865 nm, diagnostic
       REAL taue550_ss(klon) ! epaisseur optique aerosol 550 nm, diagnostic
       REAL taue670_ss(klon) ! epaisseur optique aerosol 670 nm, diagnostic
       REAL taue865_ss(klon) ! epaisseur optique aerosol 865 nm, diagnostic
       REAL taue550_dust(klon) ! epaisseur optique aerosol 550 nm, diagnostic
       REAL taue670_dust(klon) ! epaisseur optique aerosol 670 nm, diagnostic
       REAL taue865_dust(klon) ! epaisseur optique aerosol 865 nm, diagnostic
       REAL taue550_dustsco(klon) ! epaisseur optique aerosol 550 nm, diagnostic
       REAL taue670_dustsco(klon) ! epaisseur optique aerosol 670 nm, diagnostic
       REAL taue865_dustsco(klon) ! epaisseur optique aerosol 865 nm, diagnostic
+c===================== LOCAL VARIABLES ===========================
       INTEGER nb_lambda,nbre_RH
       PARAMETER (nb_lambda=3,nbre_RH=12)
       INTEGER i, k, RH_num
       REAL rh, RH_MAX, DELTA, RH_tab(nbre_RH)
       PARAMETER (RH_MAX=95.)
       INTEGER rh_int
       PARAMETER (rh_int=12)
       REAL auxreal
 c      REAL ss_a(nb_lambda,int,nbtr-1)
 c      DATA ss_a/72*1./
       REAL ss_dust(nb_lambda), ss_acc550(rh_int), alpha_acc
       REAL ss_dustsco(nb_lambda)
       REAL ss_acc670(rh_int), ss_acc865(rh_int)
       REAL ss_ssalt550(rh_int)
       REAL ss_ssalt670(rh_int), ss_ssalt865(rh_int)
       REAL burden_ss(klon)
       DATA ss_acc550 /3.135,3.135,3.135, 3.135, 4.260, 4.807,
      .                5.546,6.651,8.641,10.335,13.534,22.979/
       DATA ss_acc670 /2.220,2.220,2.220, 2.220, 3.048, 3.460,
      .                4.023,4.873,6.426, 7.761,10.322,18.079/
       DATA ss_acc865 /1.329,1.329,1.329, 1.329, 1.855, 2.124,
      .                2.494,3.060,4.114, 5.033, 6.831,12.457/
 !old4tracers      DATA ss_dust/0.564, 0.614, 0.700/ !for bin 0.5-10um
 !      DATA ss_dust/0.553117, 0.610185, 0.7053460 / !for bin 0.5-3um radius
 !      DATA ss_dustsco/0.1014, 0.102156, 0.1035538 / !for bin 3-15um radius
 !20140902      DATA ss_dust/0.5345737, 0.5878828, 0.6772957/ !for bin 0.5-3um radius
 !20140902      DATA ss_dustsco/0.1009634, 0.1018700, 0.1031178/ !for bin 3-15um radius
 !3days      DATA ss_dust/0.4564216, 0.4906738, 0.5476248/ !for bin 0.5-3um radius
 !3days      DATA ss_dustsco/0.1015022, 0.1024051, 0.1036622/ !for bin 3-15um radius
 !JE20140911      DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
 !JE20140911      DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
 !JE20140915      DATA ss_dust/0.3188754,0.3430106,0.3829019/ !for bin 0.5-5um radius
 !JE20140915      DATA ss_dustsco/8.0582686E-02,8.1255026E-02,8.1861295E-02/ !for bin 5-15um radius
 !      DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
 !      DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
       DATA ss_ssalt550/0.182,0.182,0.182,0.182,0.366,0.430,
      .                 0.484,0.551,0.648,0.724,0.847,1.218/ !for bin 0.5-20 um, fit_v2
       DATA ss_ssalt670/0.193,0.193,0.193,0.193,0.377,0.431,
      .                 0.496,0.587,0.693,0.784,0.925,1.257/ !for bin 0.5-20 um
       DATA ss_ssalt865/0.188,0.188,0.188,0.188,0.384,0.443,
      .                 0.502,0.580,0.699,0.799,0.979,1.404/ !for bin 0.5-20 um
       DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+c
       IF (ok_chimeredust) THEN
 !JE20150212<< : changes in ustar in dustmod changes emission distribution
 !      ss_dust=(/0.5167768,0.5684330,0.6531643/)
 !      ss_dustsco=(/0.1003391,0.1012288,0.1024651/)
 ! JE20150618: Change in dustmodule, div3 is now =6: change distributions
 ! div3=3      ss_dust   =(/0.4670522 , 0.5077308 , 0.5745184/)
 ! div3=3      ss_dustsco=(/0.099858  , 0.1007395 , 0.1019673/)
       ss_dust   =(/0.4851232 , 0.5292494 , 0.5935509/)
       ss_dustsco=(/0.1001981 , 0.1011043 , 0.1023113/)
 !JE20150212>>
       ELSE
       ss_dust=(/0.564, 0.614, 0.700/)
       ss_dustsco=(/0.,0.,0./)
       ENDIF
       DO i=1, klon
         ztaue550(i)=0.0
         ztaue670(i)=0.0
         ztaue865(i)=0.0
         taue550_tr2(i)=0.0
         taue670_tr2(i)=0.0
         taue865_tr2(i)=0.0
         taue550_ss(i)=0.0
         taue670_ss(i)=0.0
         taue865_ss(i)=0.0
         taue550_dust(i)=0.0
         taue670_dust(i)=0.0
         taue865_dust(i)=0.0
         taue550_dustsco(i)=0.0
         taue670_dustsco(i)=0.0
         taue865_dustsco(i)=0.0
         burden_ss(i)=0.0
       ENDDO
       DO k=1, klev
       DO i=1, klon
+c
       rh=MIN(RHcl(i,k)*100.,RH_MAX)
       RH_num = INT( rh/10. + 1.)
       IF (rh.gt.85.) RH_num=10
       IF (rh.gt.90.) RH_num=11
+c      IF (rh.gt.40.) THEN
 c          RH_num=5   ! Added by NHL temporarily
 c          print *,'TEMPORARY CASE'
 c      ENDIF
       DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
 c*******************************************************************
 c                       AOD at 550 NM
 c*******************************************************************
         alpha_acc=ss_acc550(RH_num) + DELTA*(ss_acc550(RH_num+1)-
      .            ss_acc550(RH_num))              !--m2/g
 cnhl_test TOTAL AOD
        auxreal=0.
       IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
       IF(id_coss>0) auxreal=auxreal+ss_ssalt550(RH_num)*
      .                       tr_seri(i,k,id_coss)
       IF(id_codu>0) auxreal=auxreal+ss_dust(1)*tr_seri(i,k,id_codu)
       IF(id_scdu>0) auxreal=auxreal+ss_dustsco(1)*tr_seri(i,k,id_scdu)
       ztaue550(i)=ztaue550(i)+auxreal*zdz(i,k)*1.e6
 !JE20150128        ztaue550(i)=ztaue550(i)+(alpha_acc*tr_seri(i,k,id_fine)+
 !     .                 ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)+
 !     .                 ss_dust(1)*tr_seri(i,k,id_codu)+
 !     .              ss_dustsco(1)*tr_seri(i,k,id_scdu)  )*zdz(i,k)*1.e6
 cnhl_test TOTAL AOD IS NOW AOD COARSE MODE ONLY
+cnhl_test        ztaue550(i)=ztaue550(i)+(
 cnhl_test     .                 ss_ssalt550(RH_num)*tr_seri(i,k,3)+
 cnhl_test     .                 ss_dust(1)*tr_seri(i,k,4))*zdz(i,k)*1.e6
         IF(id_fine>0) taue550_tr2(i)=taue550_tr2(i)
      .               + alpha_acc*tr_seri(i,k,id_fine)*zdz(i,k)*1.e6
         IF(id_coss>0) taue550_ss(i)=taue550_ss(i)+
      .                ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)*
      .                zdz(i,k)*1.e6
         IF(id_codu>0) taue550_dust(i)=taue550_dust(i)+
      .                ss_dust(1)*tr_seri(i,k,id_codu)*
      .                zdz(i,k)*1.e6
         IF(id_scdu>0) taue550_dustsco(i)=taue550_dustsco(i)+
      .                ss_dustsco(1)*tr_seri(i,k,id_scdu)*
      .                zdz(i,k)*1.e6
 !        print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
 !     .                                          MAXVAL(taue550_ss)
 c*******************************************************************
 c                       AOD at 670 NM
 c*******************************************************************
         alpha_acc=ss_acc670(RH_num) + DELTA*(ss_acc670(RH_num+1)-
      .            ss_acc670(RH_num))              !--m2/g
       auxreal=0.
       IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
       IF(id_coss>0) auxreal=auxreal+ss_ssalt670(RH_num)
      .                      *tr_seri(i,k,id_coss)
       IF(id_codu>0) auxreal=auxreal+ss_dust(2)*tr_seri(i,k,id_codu)
       IF(id_scdu>0) auxreal=auxreal+ss_dustsco(2)*tr_seri(i,k,id_scdu)
       ztaue670(i)=ztaue670(i)+auxreal*zdz(i,k)*1.e6
 !JE20150128        ztaue670(i)=ztaue670(i)+(alpha_acc*tr_seri(i,k,id_fine)+
 !     .                 ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)+
 !     .                 ss_dust(2)*tr_seri(i,k,id_codu)+
 !     .               ss_dustsco(2)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
       IF(id_fine>0)  taue670_tr2(i)=taue670_tr2(i)+
      .                alpha_acc*tr_seri(i,k,id_fine)*
      .                 zdz(i,k)*1.e6
       IF(id_coss>0)  taue670_ss(i)=taue670_ss(i)+
      .                ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)*
      .                zdz(i,k)*1.e6
       IF(id_codu>0)  taue670_dust(i)=taue670_dust(i)
      .                +ss_dust(2)*tr_seri(i,k,id_codu)*
      .                zdz(i,k)*1.e6
       IF(id_scdu>0)  taue670_dustsco(i)=taue670_dustsco(i)+
      .                ss_dustsco(2)*tr_seri(i,k,id_scdu)*
      .                zdz(i,k)*1.e6
 c*******************************************************************
 c                       AOD at 865 NM
 c*******************************************************************
         alpha_acc=ss_acc865(RH_num) + DELTA*(ss_acc865(RH_num+1)-
      .            ss_acc865(RH_num))              !--m2/g
         auxreal=0.
       IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
       IF(id_coss>0) auxreal=auxreal
      .                     +ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)
       IF(id_codu>0) auxreal=auxreal+ss_dust(3)*tr_seri(i,k,id_codu)
       IF(id_scdu>0) auxreal=auxreal+ss_dustsco(3)*tr_seri(i,k,id_scdu)
         ztaue865(i)=ztaue865(i)+auxreal*zdz(i,k)*1.e6
 !JE20150128        ztaue865(i)=ztaue865(i)+(alpha_acc*tr_seri(i,k,id_fine)+
 !     .                 ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)+
 !     .                 ss_dust(3)*tr_seri(i,k,id_codu)+
 !     .               ss_dustsco(3)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
       IF(id_fine>0) taue865_tr2(i)=taue865_tr2(i)
      .                +alpha_acc*tr_seri(i,k,id_fine)*
      .                 zdz(i,k)*1.e6
       IF(id_coss>0) taue865_ss(i)=taue865_ss(i)+
      .                ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)*
      .                zdz(i,k)*1.e6
       IF(id_codu>0)  taue865_dust(i)=taue865_dust(i)
      .                +ss_dust(3)*tr_seri(i,k,id_codu)*
      .                zdz(i,k)*1.e6
       IF(id_scdu>0)  taue865_dustsco(i)=taue865_dustsco(i)+
      .                ss_dustsco(3)*tr_seri(i,k,id_scdu)*
      .                zdz(i,k)*1.e6
+c
       IF(id_coss>0)  burden_ss(i)=burden_ss(i)
      .                +tr_seri(i,k,id_coss)*1.e6*1.e3*zdz(i,k)
       ENDDO            !-loop on klev
       ENDDO            !-loop on klon
 !      print *,'tr_seri = ',SUM(tr_seri(:,:,3)),MINVAL(tr_seri(:,:,3)),
 !     .                                          MAXVAL(tr_seri(:,:,3))
 !      print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
 !     .                                        MAXVAL(taue550_ss)
+c
       RETURN
+      END
+SUBROUTINE aeropt_spl(zdz, tr_seri, RHcl, &
+        id_prec, id_fine, id_coss, id_codu, id_scdu, &
+        ok_chimeredust, &
+        ztaue550,ztaue670,ztaue865, &
+        taue550_tr2,taue670_tr2,taue865_tr2, &
+        taue550_ss,taue670_ss,taue865_ss, &
+        taue550_dust,taue670_dust,taue865_dust, &
+        taue550_dustsco,taue670_dustsco,taue865_dustsco)
+  !
+  USE dimphy
+  USE infotrac
+  IMPLICIT none
+  !
+  INCLUDE "chem.h"
+  INCLUDE "dimensions.h"
+  !INCLUDE "dimphy.h"
+  INCLUDE "YOMCST.h"
+  !
+  ! Arguments:
+  !
+  !======================== INPUT ==================================
+  REAL :: zdz(klon,klev)
+  REAL :: tr_seri(klon,klev,nbtr) ! masse of tracer
+  REAL :: RHcl(klon,klev)     ! humidite relativen ciel clair
+  INTEGER :: id_prec, id_fine, id_coss, id_codu, id_scdu
+  LOGICAL :: ok_chimeredust
+  !============================== OUTPUT =================================
+  REAL :: ztaue550(klon) ! epaisseur optique aerosol 550 nm
+  REAL :: ztaue670(klon) ! epaisseur optique aerosol 670 nm
+  REAL :: ztaue865(klon) ! epaisseur optique aerosol 865 nm
+  REAL :: taue550_tr2(klon) ! epaisseur optique aerosol 550 nm, diagnostic
+  REAL :: taue670_tr2(klon) ! epaisseur optique aerosol 670 nm, diagnostic
+  REAL :: taue865_tr2(klon) ! epaisseur optique aerosol 865 nm, diagnostic
+  REAL :: taue550_ss(klon) ! epaisseur optique aerosol 550 nm, diagnostic
+  REAL :: taue670_ss(klon) ! epaisseur optique aerosol 670 nm, diagnostic
+  REAL :: taue865_ss(klon) ! epaisseur optique aerosol 865 nm, diagnostic
+  REAL :: taue550_dust(klon) ! epaisseur optique aerosol 550 nm, diagnostic
+  REAL :: taue670_dust(klon) ! epaisseur optique aerosol 670 nm, diagnostic
+  REAL :: taue865_dust(klon) ! epaisseur optique aerosol 865 nm, diagnostic
+  REAL :: taue550_dustsco(klon) ! epaisseur optique aerosol 550 nm, diagnostic
+  REAL :: taue670_dustsco(klon) ! epaisseur optique aerosol 670 nm, diagnostic
+  REAL :: taue865_dustsco(klon) ! epaisseur optique aerosol 865 nm, diagnostic
+  !===================== LOCAL VARIABLES ===========================
+  INTEGER :: nb_lambda,nbre_RH
+  PARAMETER (nb_lambda=3,nbre_RH=12)
+  INTEGER :: i, k, RH_num
+  REAL :: rh, RH_MAX, DELTA, RH_tab(nbre_RH)
+  PARAMETER (RH_MAX=95.)
+  INTEGER :: rh_int
+  PARAMETER (rh_int=12)
+  REAL :: auxreal
+   ! REAL ss_a(nb_lambda,int,nbtr-1)
+   ! DATA ss_a/72*1./
+  REAL :: ss_dust(nb_lambda), ss_acc550(rh_int), alpha_acc
+  REAL :: ss_dustsco(nb_lambda)
+  REAL :: ss_acc670(rh_int), ss_acc865(rh_int)
+  REAL :: ss_ssalt550(rh_int)
+  REAL :: ss_ssalt670(rh_int), ss_ssalt865(rh_int)
+  REAL :: burden_ss(klon)
+  DATA ss_acc550 /3.135,3.135,3.135, 3.135, 4.260, 4.807, &
+.546,6.651,8.641,10.335,13.534,22.979/
+  DATA ss_acc670 /2.220,2.220,2.220, 2.220, 3.048, 3.460, &
+.023,4.873,6.426, 7.761,10.322,18.079/
+  DATA ss_acc865 /1.329,1.329,1.329, 1.329, 1.855, 2.124, &
+.494,3.060,4.114, 5.033, 6.831,12.457/
+  !old4tracers      DATA ss_dust/0.564, 0.614, 0.700/ !for bin 0.5-10um
+   ! DATA ss_dust/0.553117, 0.610185, 0.7053460 / !for bin 0.5-3um radius
+   ! DATA ss_dustsco/0.1014, 0.102156, 0.1035538 / !for bin 3-15um radius
+  !20140902      DATA ss_dust/0.5345737, 0.5878828, 0.6772957/ !for bin 0.5-3um radius
+  !20140902      DATA ss_dustsco/0.1009634, 0.1018700, 0.1031178/ !for bin 3-15um radius
+  !3days      DATA ss_dust/0.4564216, 0.4906738, 0.5476248/ !for bin 0.5-3um radius
+  !3days      DATA ss_dustsco/0.1015022, 0.1024051, 0.1036622/ !for bin 3-15um radius
+  !JE20140911      DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
+  !JE20140911      DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
+  !JE20140915      DATA ss_dust/0.3188754,0.3430106,0.3829019/ !for bin 0.5-5um radius
+  !JE20140915      DATA ss_dustsco/8.0582686E-02,8.1255026E-02,8.1861295E-02/ !for bin 5-15um radius
+   ! DATA ss_dust/0.5167768,0.5684330,0.6531643/ !for bin 0.5-3um radius
+   ! DATA ss_dustsco/0.1003391,0.1012288,0.1024651/ !for bin 3-15um radius
+  DATA ss_ssalt550/0.182,0.182,0.182,0.182,0.366,0.430, &
+.484,0.551,0.648,0.724,0.847,1.218/ !for bin 0.5-20 um, fit_v2
+  DATA ss_ssalt670/0.193,0.193,0.193,0.193,0.377,0.431, &
+.496,0.587,0.693,0.784,0.925,1.257/ !for bin 0.5-20 um
+  DATA ss_ssalt865/0.188,0.188,0.188,0.188,0.384,0.443, &
+.502,0.580,0.699,0.799,0.979,1.404/ !for bin 0.5-20 um
+  DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+  !
+  IF (ok_chimeredust) THEN
+  !JE20150212<< : changes in ustar in dustmod changes emission distribution
+   ! ss_dust=(/0.5167768,0.5684330,0.6531643/)
+   ! ss_dustsco=(/0.1003391,0.1012288,0.1024651/)
+  ! JE20150618: Change in dustmodule, div3 is now =6: change distributions
+  ! div3=3      ss_dust   =(/0.4670522 , 0.5077308 , 0.5745184/)
+  ! div3=3      ss_dustsco=(/0.099858  , 0.1007395 , 0.1019673/)
+  ss_dust   =(/0.4851232 , 0.5292494 , 0.5935509/)
+  ss_dustsco=(/0.1001981 , 0.1011043 , 0.1023113/)
+  !JE20150212>>
+  ELSE
+  ss_dust=(/0.564, 0.614, 0.700/)
+  ss_dustsco=(/0.,0.,0./)
+  ENDIF
+  DO i=1, klon
+    ztaue550(i)=0.0
+    ztaue670(i)=0.0
+    ztaue865(i)=0.0
+    taue550_tr2(i)=0.0
+    taue670_tr2(i)=0.0
+    taue865_tr2(i)=0.0
+    taue550_ss(i)=0.0
+    taue670_ss(i)=0.0
+    taue865_ss(i)=0.0
+    taue550_dust(i)=0.0
+    taue670_dust(i)=0.0
+    taue865_dust(i)=0.0
+    taue550_dustsco(i)=0.0
+    taue670_dustsco(i)=0.0
+    taue865_dustsco(i)=0.0
+    burden_ss(i)=0.0
+  ENDDO
+  DO k=1, klev
+  DO i=1, klon
+  !
+  rh=MIN(RHcl(i,k)*100.,RH_MAX)
+  RH_num = INT( rh/10. + 1.)
+  IF (rh.gt.85.) RH_num=10
+  IF (rh.gt.90.) RH_num=11
+   ! IF (rh.gt.40.) THEN
+   !     RH_num=5   ! Added by NHL temporarily
+   !     print *,'TEMPORARY CASE'
+   ! ENDIF
+  DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+  !*******************************************************************
+                    ! AOD at 550 NM
+  !*******************************************************************
+    alpha_acc=ss_acc550(RH_num) + DELTA*(ss_acc550(RH_num+1)- &
+          ss_acc550(RH_num))              !--m2/g
+  !nhl_test TOTAL AOD
+   auxreal=0.
+  IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
+  IF(id_coss>0) auxreal=auxreal+ss_ssalt550(RH_num)* &
+        tr_seri(i,k,id_coss)
+  IF(id_codu>0) auxreal=auxreal+ss_dust(1)*tr_seri(i,k,id_codu)
+  IF(id_scdu>0) auxreal=auxreal+ss_dustsco(1)*tr_seri(i,k,id_scdu)
+  ztaue550(i)=ztaue550(i)+auxreal*zdz(i,k)*1.e6
+  !JE20150128        ztaue550(i)=ztaue550(i)+(alpha_acc*tr_seri(i,k,id_fine)+
+  ! .                 ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)+
+  ! .                 ss_dust(1)*tr_seri(i,k,id_codu)+
+  ! .              ss_dustsco(1)*tr_seri(i,k,id_scdu)  )*zdz(i,k)*1.e6
+  !nhl_test TOTAL AOD IS NOW AOD COARSE MODE ONLY
+  !nhl_test        ztaue550(i)=ztaue550(i)+(
+  !nhl_test     .                 ss_ssalt550(RH_num)*tr_seri(i,k,3)+
+  !nhl_test     .                 ss_dust(1)*tr_seri(i,k,4))*zdz(i,k)*1.e6
+    IF(id_fine>0) taue550_tr2(i)=taue550_tr2(i) &
+          + alpha_acc*tr_seri(i,k,id_fine)*zdz(i,k)*1.e6
+    IF(id_coss>0) taue550_ss(i)=taue550_ss(i)+ &
+          ss_ssalt550(RH_num)*tr_seri(i,k,id_coss)* &
+          zdz(i,k)*1.e6
+    IF(id_codu>0) taue550_dust(i)=taue550_dust(i)+ &
+          ss_dust(1)*tr_seri(i,k,id_codu)* &
+          zdz(i,k)*1.e6
+    IF(id_scdu>0) taue550_dustsco(i)=taue550_dustsco(i)+ &
+          ss_dustsco(1)*tr_seri(i,k,id_scdu)* &
+          zdz(i,k)*1.e6
+     ! print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
+  ! .                                          MAXVAL(taue550_ss)
+  !*******************************************************************
+  !                   AOD at 670 NM
+  !*******************************************************************
+    alpha_acc=ss_acc670(RH_num) + DELTA*(ss_acc670(RH_num+1)- &
+          ss_acc670(RH_num))              !--m2/g
+  auxreal=0.
+  IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
+  IF(id_coss>0) auxreal=auxreal+ss_ssalt670(RH_num) &
+        *tr_seri(i,k,id_coss)
+  IF(id_codu>0) auxreal=auxreal+ss_dust(2)*tr_seri(i,k,id_codu)
+  IF(id_scdu>0) auxreal=auxreal+ss_dustsco(2)*tr_seri(i,k,id_scdu)
+  ztaue670(i)=ztaue670(i)+auxreal*zdz(i,k)*1.e6
+  !JE20150128        ztaue670(i)=ztaue670(i)+(alpha_acc*tr_seri(i,k,id_fine)+
+  ! .                 ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)+
+  ! .                 ss_dust(2)*tr_seri(i,k,id_codu)+
+  ! .               ss_dustsco(2)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
+  IF(id_fine>0)  taue670_tr2(i)=taue670_tr2(i)+ &
+        alpha_acc*tr_seri(i,k,id_fine)* &
+        zdz(i,k)*1.e6
+  IF(id_coss>0)  taue670_ss(i)=taue670_ss(i)+ &
+        ss_ssalt670(RH_num)*tr_seri(i,k,id_coss)* &
+        zdz(i,k)*1.e6
+  IF(id_codu>0)  taue670_dust(i)=taue670_dust(i) &
+        +ss_dust(2)*tr_seri(i,k,id_codu)* &
+        zdz(i,k)*1.e6
+  IF(id_scdu>0)  taue670_dustsco(i)=taue670_dustsco(i)+ &
+        ss_dustsco(2)*tr_seri(i,k,id_scdu)* &
+        zdz(i,k)*1.e6
+  !*******************************************************************
+                    ! AOD at 865 NM
+  !*******************************************************************
+    alpha_acc=ss_acc865(RH_num) + DELTA*(ss_acc865(RH_num+1)- &
+          ss_acc865(RH_num))              !--m2/g
+    auxreal=0.
+  IF(id_fine>0) auxreal=auxreal+alpha_acc*tr_seri(i,k,id_fine)
+  IF(id_coss>0) auxreal=auxreal &
+        +ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)
+  IF(id_codu>0) auxreal=auxreal+ss_dust(3)*tr_seri(i,k,id_codu)
+  IF(id_scdu>0) auxreal=auxreal+ss_dustsco(3)*tr_seri(i,k,id_scdu)
+    ztaue865(i)=ztaue865(i)+auxreal*zdz(i,k)*1.e6
+  !JE20150128        ztaue865(i)=ztaue865(i)+(alpha_acc*tr_seri(i,k,id_fine)+
+  ! .                 ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)+
+  ! .                 ss_dust(3)*tr_seri(i,k,id_codu)+
+  ! .               ss_dustsco(3)*tr_seri(i,k,id_scdu))*zdz(i,k)*1.e6
+  IF(id_fine>0) taue865_tr2(i)=taue865_tr2(i) &
+        +alpha_acc*tr_seri(i,k,id_fine)* &
+        zdz(i,k)*1.e6
+  IF(id_coss>0) taue865_ss(i)=taue865_ss(i)+ &
+        ss_ssalt865(RH_num)*tr_seri(i,k,id_coss)* &
+        zdz(i,k)*1.e6
+  IF(id_codu>0)  taue865_dust(i)=taue865_dust(i) &
+        +ss_dust(3)*tr_seri(i,k,id_codu)* &
+        zdz(i,k)*1.e6
+  IF(id_scdu>0)  taue865_dustsco(i)=taue865_dustsco(i)+ &
+        ss_dustsco(3)*tr_seri(i,k,id_scdu)* &
+        zdz(i,k)*1.e6
+  !
+  IF(id_coss>0)  burden_ss(i)=burden_ss(i) &
+        +tr_seri(i,k,id_coss)*1.e6*1.e3*zdz(i,k)
+  ENDDO            !-loop on klev
+  ENDDO            !-loop on klon
+   ! print *,'tr_seri = ',SUM(tr_seri(:,:,3)),MINVAL(tr_seri(:,:,3)),
+  ! .                                          MAXVAL(tr_seri(:,:,3))
+  !  print *,'taue550_ss = ',SUM(taue550_ss),MINVAL(taue550_ss),
+  ! .                                        MAXVAL(taue550_ss)
+  !
+  RETURN
+END SUBROUTINE aeropt_spl

LMDZ6/trunk/libf/phylmd/Dust/bcscav_spl.f90

-                      r5245
+                      r5246
+      SUBROUTINE bcscav_spl(pdtime,flxr,flxs,alpha_r,alpha_s,x,dx)
+SUBROUTINE bcscav_spl(pdtime,flxr,flxs,alpha_r,alpha_s,x,dx)
       USE dimphy
       IMPLICIT NONE
 c=====================================================================
 c Objet : below-cloud scavenging of tracers
 c Date : september 1999
+c Auteur: O. Boucher (LOA)
 c=====================================================================
+c
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "YOECUMF.h"
+c
       REAL pdtime, alpha_r, alpha_s, R_r, R_s
       PARAMETER (R_r=0.001)          !--mean raindrop radius (m)
       PARAMETER (R_s=0.001)          !--mean snow crystal radius (m)
       REAL flxr(klon,klev)         ! liquid precipitation rate (kg/m2/s)
       REAL flxs(klon,klev)         ! solid  precipitation rate (kg/m2/s)
       REAL flxr_aux(klon,klev+1)
       REAL flxs_aux(klon,klev+1)
       REAL x(klon,klev)              ! q de traceur
       REAL dx(klon,klev)             ! tendance de traceur
+c
+c--variables locales
       INTEGER i, k
       REAL pr, ps, ice, water
+c
 c------------------------------------------
+c
 ! NHL
 ! Auxiliary variables defined to deal with the fact that precipitation
 ! fluxes are defined on klev levels only.
 ! NHL
+!
       flxr_aux(:,klev+1)=0.0
       flxs_aux(:,klev+1)=0.0
       flxr_aux(:,1:klev)=flxr(:,:)
       flxs_aux(:,1:klev)=flxs(:,:)
+!
       DO k=1, klev
       DO i=1, klon
        pr=0.5*(flxr_aux(i,k)+flxr_aux(i,k+1))
        ps=0.5*(flxs_aux(i,k)+flxs_aux(i,k+1))
        water=pr*alpha_r/R_r/rho_water
        ice=ps*alpha_s/R_s/rho_ice
        dx(i,k)=-3./4.*x(i,k)*pdtime*(water+ice)
+ctmp       dx(i,k)=-3./4.*x(i,k)*pdtime*
 ctmp     .         (pr*alpha_r/R_r/rho_water+ps*alpha_s/R_s/rho_ice)
       ENDDO
       ENDDO
+c
       RETURN
+      END
+  USE dimphy
+  IMPLICIT NONE
+  !=====================================================================
+  ! Objet : below-cloud scavenging of tracers
+  ! Date : september 1999
+  ! Auteur: O. Boucher (LOA)
+  !=====================================================================
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h"
+  !
+  REAL :: pdtime, alpha_r, alpha_s, R_r, R_s
+  PARAMETER (R_r=0.001)          !--mean raindrop radius (m)
+  PARAMETER (R_s=0.001)          !--mean snow crystal radius (m)
+  REAL :: flxr(klon,klev)         ! liquid precipitation rate (kg/m2/s)
+  REAL :: flxs(klon,klev)         ! solid  precipitation rate (kg/m2/s)
+  REAL :: flxr_aux(klon,klev+1)
+  REAL :: flxs_aux(klon,klev+1)
+  REAL :: x(klon,klev)              ! q de traceur
+  REAL :: dx(klon,klev)             ! tendance de traceur
+  !
+  !--variables locales
+  INTEGER :: i, k
+  REAL :: pr, ps, ice, water
+  !
+  !------------------------------------------
+  !
+  ! NHL
+  ! Auxiliary variables defined to deal with the fact that precipitation
+  ! fluxes are defined on klev levels only.
+  ! NHL
+  !
+  flxr_aux(:,klev+1)=0.0
+  flxs_aux(:,klev+1)=0.0
+  flxr_aux(:,1:klev)=flxr(:,:)
+  flxs_aux(:,1:klev)=flxs(:,:)
+  !
+  DO k=1, klev
+  DO i=1, klon
+   pr=0.5*(flxr_aux(i,k)+flxr_aux(i,k+1))
+   ps=0.5*(flxs_aux(i,k)+flxs_aux(i,k+1))
+   water=pr*alpha_r/R_r/rho_water
+   ice=ps*alpha_s/R_s/rho_ice
+   dx(i,k)=-3./4.*x(i,k)*pdtime*(water+ice)
+  !tmp       dx(i,k)=-3./4.*x(i,k)*pdtime*
+  !tmp     .         (pr*alpha_r/R_r/rho_water+ps*alpha_s/R_s/rho_ice)
+  ENDDO
+  ENDDO
+  !
+  RETURN
+END SUBROUTINE bcscav_spl

LMDZ6/trunk/libf/phylmd/Dust/bl_for_dms.f90

-                      r5245
+                      r5246
+      SUBROUTINE bl_for_dms(u,v,paprs,pplay,cdragh,cdragm
      .                     ,t,q,tsol,ustar,obklen)
       USE dimphy
       IMPLICIT NONE
+c
 c===================================================================
+c Auteur : E. Cosme
+c Calcul de la vitesse de friction (ustar) et de la longueur de
 c Monin-Obukhov (obklen), necessaires pour calculer les flux de DMS
 c par la methode de Nightingale.
 c Cette subroutine est plus que fortement inspiree de la subroutine
 c 'nonlocal' dans clmain.F .
 c reference :  Holtslag, A.A.M., and B.A. Boville, 1993:
 c Local versus nonlocal boundary-layer diffusion in a global climate
 c model. J. of Climate, vol. 6, 1825-1842. (a confirmer)
 c 31 08 01
 c===================================================================
+c
       INCLUDE "dimensions.h"
       INCLUDE "YOMCST.h"
       INCLUDE "YOETHF.h"
       INCLUDE "FCTTRE.h"
+c
 c Arguments :
       REAL u(klon,klev)          ! vent zonal
       REAL v(klon,klev)          ! vent meridien
       REAL paprs(klon,klev+1)    ! niveaux de pression aux intercouches (Pa)
       REAL pplay(klon,klev)      ! niveaux de pression aux milieux... (Pa)
       REAL cdragh(klon)          ! coefficient de trainee pour la chaleur
       REAL cdragm(klon)          ! coefficient de trainee pour le vent
       REAL t(klon,klev)          ! temperature
       REAL q(klon,klev)          ! humidite kg/kg
       REAL tsol(klon)            ! temperature du sol
       REAL ustar(klon)           ! vitesse de friction
       REAL obklen(klon)          ! longueur de Monin-Obukhov
+c
 c Locales :
       REAL vk
       PARAMETER (vk=0.35)
       REAL beta  ! coefficient d'evaporation reelle (/evapotranspiration)
                  ! entre 0 et 1, mais 1 au-dessus de la mer
       PARAMETER (beta=1.)
       INTEGER i,k
       REAL zxt, zxu, zxv, zxq, zxqs, zxmod, taux, tauy
       REAL zcor, zdelta, zcvm5
       REAL z(klon,klev)
       REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
       REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
       REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
       REAL heatv(klon)      ! surface virtual heat flux
+SUBROUTINE bl_for_dms(u,v,paprs,pplay,cdragh,cdragm &
+        ,t,q,tsol,ustar,obklen)
+  USE dimphy
+  IMPLICIT NONE
+  !
+  !===================================================================
+  ! Auteur : E. Cosme
+  ! Calcul de la vitesse de friction (ustar) et de la longueur de
+  ! Monin-Obukhov (obklen), necessaires pour calculer les flux de DMS
+  ! par la methode de Nightingale.
+  ! Cette subroutine est plus que fortement inspiree de la subroutine
+  ! 'nonlocal' dans clmain.F .
+  ! reference :  Holtslag, A.A.M., and B.A. Boville, 1993:
+  ! Local versus nonlocal boundary-layer diffusion in a global climate
+  ! model. J. of Climate, vol. 6, 1825-1842. (a confirmer)
+  ! 31 08 01
+  !===================================================================
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "FCTTRE.h"
+  !
+  ! Arguments :
+  REAL :: u(klon,klev)          ! vent zonal
+  REAL :: v(klon,klev)          ! vent meridien
+  REAL :: paprs(klon,klev+1)    ! niveaux de pression aux intercouches (Pa)
+  REAL :: pplay(klon,klev)      ! niveaux de pression aux milieux... (Pa)
+  REAL :: cdragh(klon)          ! coefficient de trainee pour la chaleur
+  REAL :: cdragm(klon)          ! coefficient de trainee pour le vent
+  REAL :: t(klon,klev)          ! temperature
+  REAL :: q(klon,klev)          ! humidite kg/kg
+  REAL :: tsol(klon)            ! temperature du sol
+  REAL :: ustar(klon)           ! vitesse de friction
+  REAL :: obklen(klon)          ! longueur de Monin-Obukhov
+  !
+  ! Locales :
+  REAL :: vk
+  PARAMETER (vk=0.35)
+  REAL :: beta  ! coefficient d'evaporation reelle (/evapotranspiration)
+             ! ! entre 0 et 1, mais 1 au-dessus de la mer
+  PARAMETER (beta=1.)
+  INTEGER :: i,k
+  REAL :: zxt, zxu, zxv, zxq, zxqs, zxmod, taux, tauy
+  REAL :: zcor, zdelta, zcvm5
+  REAL :: z(klon,klev)
+  REAL :: zx_alf1, zx_alf2 ! parametres pour extrapolation
+  REAL :: khfs(klon)       ! surface kinematic heat flux [mK/s]
+  REAL :: kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+  REAL :: heatv(klon)      ! surface virtual heat flux
+c
-c======================================================================
+c
-c Calculer les hauteurs de chaque couche
+c
-! JE20150707      r2es=611.14 *18.0153/28.9644
-      DO i = 1, klon
-         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
-     .               * (paprs(i,1)-pplay(i,1)) / RG
-      ENDDO
-      DO k = 2, klev
-      DO i = 1, klon
-         z(i,k) = z(i,k-1)
-     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
-     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
-      ENDDO
-      ENDDO
+      DO i = 1, klon
+c
+        zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+        zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+        zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+        zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+        zxqs=MIN(0.5,zxqs)
+        zcor=1./(1.-retv*zxqs)
+        zxqs=zxqs*zcor
+c
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .        *(1.+RETV*q(i,1))*zx_alf1
+     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+     .        *(1.+RETV*q(i,2))*zx_alf2
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cdragh(i)
+        kqfs(i) = (zxqs-zxq) *zxmod*cdragh(i) * beta
+        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+        taux = zxu *zxmod*cdragm(i)
+        tauy = zxv *zxmod*cdragm(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+c
+      ENDDO
+c
+      DO i = 1, klon
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+      ENDDO
+c
+      END SUBROUTINE
+  !
+  !======================================================================
+  !
+  ! Calculer les hauteurs de chaque couche
+  !
+  ! JE20150707      r2es=611.14 *18.0153/28.9644
+  DO i = 1, klon
+     z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+           * (paprs(i,1)-pplay(i,1)) / RG
+  ENDDO
+  DO k = 2, klev
+  DO i = 1, klon
+     z(i,k) = z(i,k-1) &
+           + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+           * (pplay(i,k-1)-pplay(i,k)) / RG
+  ENDDO
+  ENDDO
+  DO i = 1, klon
+  !
+    zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+    zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+    zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+    zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+    zxqs=MIN(0.5,zxqs)
+    zcor=1./(1.-retv*zxqs)
+    zxqs=zxqs*zcor
+  !
+    zx_alf1 = 1.0
+    zx_alf2 = 1.0 - zx_alf1
+    zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1))) &
+          *(1.+RETV*q(i,1))*zx_alf1 &
+          + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2))) &
+          *(1.+RETV*q(i,2))*zx_alf2
+    zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+    zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+    zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+    zxmod = 1.0+SQRT(zxu**2+zxv**2)
+    khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cdragh(i)
+    kqfs(i) = (zxqs-zxq) *zxmod*cdragh(i) * beta
+    heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+    taux = zxu *zxmod*cdragm(i)
+    tauy = zxv *zxmod*cdragm(i)
+    ustar(i) = SQRT(taux**2+tauy**2)
+    ustar(i) = MAX(SQRT(ustar(i)),0.01)
+  !
+  ENDDO
+  !
+  DO i = 1, klon
+     obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+  ENDDO
+  !
+END SUBROUTINE

LMDZ6/trunk/libf/phylmd/Dust/blcloud_scav.f90

-                      r5245
+                      r5246
 c Subroutine that calculates the effect of precipitation in scavenging
 c BELOW the cloud, for large scale as well as convective precipitation
+      SUBROUTINE blcloud_scav(lminmax,qmin,qmax,pdtphys,prfl,psfl,
      .                        pmflxr,pmflxs,zdz,alpha_r,alpha_s,masse,
      .                                  his_dhbclsc,his_dhbccon,tr_seri)
+! Subroutine that calculates the effect of precipitation in scavenging
+! BELOW the cloud, for large scale as well as convective precipitation
+SUBROUTINE blcloud_scav(lminmax,qmin,qmax,pdtphys,prfl,psfl, &
+        pmflxr,pmflxs,zdz,alpha_r,alpha_s,masse, &
+        his_dhbclsc,his_dhbccon,tr_seri)
       USE dimphy
       USE indice_sol_mod
       USE infotrac
       IMPLICIT NONE
+  USE dimphy
+  USE indice_sol_mod
+  USE infotrac
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
 c============================= INPUT ===================================
       REAL qmin,qmax
       REAL pdtphys  ! pas d'integration pour la physique (seconde)
 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
       REAL alpha_r(nbtr)!--coefficient d'impaction pour la pluie
       REAL alpha_s(nbtr)!--coefficient d'impaction pour la neige
       REAL masse(nbtr)
       LOGICAL lminmax
       REAL zdz(klon,klev)
       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
 c============================= OUTPUT ==================================
       REAL tr_seri(klon,klev,nbtr) ! traceur
       REAL aux_var1(klon,klev) ! traceur
       REAL aux_var2(klon,klev) ! traceur
       REAL his_dhbclsc(klon,nbtr), his_dhbccon(klon,nbtr)
+c========================= LOCAL VARIABLES =============================
       INTEGER it, k, i, j
       REAL d_tr(klon,klev,nbtr)
+  !============================= INPUT ===================================
+  REAL :: qmin,qmax
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+   ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+   ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+  REAL :: alpha_r(nbtr)!--coefficient d'impaction pour la pluie
+  REAL :: alpha_s(nbtr)!--coefficient d'impaction pour la neige
+  REAL :: masse(nbtr)
+  LOGICAL :: lminmax
+  REAL :: zdz(klon,klev)
+  REAL :: prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
+  REAL :: pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
+  !============================= OUTPUT ==================================
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: aux_var1(klon,klev) ! traceur
+  REAL :: aux_var2(klon,klev) ! traceur
+  REAL :: his_dhbclsc(klon,nbtr), his_dhbccon(klon,nbtr)
+  !========================= LOCAL VARIABLES =============================
+  INTEGER :: it, k, i, j
+  REAL :: d_tr(klon,klev,nbtr)
       EXTERNAL minmaxqfi, bcscav_spl
       DO it=1, nbtr
+c
       DO j=1,klev
       DO i=1,klon
         aux_var1(i,j)=tr_seri(i,j,it)
         aux_var2(i,j)=d_tr(i,j,it)
       ENDDO
       ENDDO
+c
 cnhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
       CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
      .                aux_var1,aux_var2)
+c
       DO j=1,klev
       DO i=1,klon
         tr_seri(i,j,it)=aux_var1(i,j)
         d_tr(i,j,it)=aux_var2(i,j)
       ENDDO
       ENDDO
       DO k = 1, klev
       DO i = 1, klon
          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
          his_dhbclsc(i,it)=his_dhbclsc(i,it)-d_tr(i,k,it)/RNAVO*
      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys  !--mgS/m2/s
       ENDDO
       ENDDO
+c
       DO i=1,klon
       DO j=1,klev
         aux_var1(i,j)=tr_seri(i,j,it)
         aux_var2(i,j)=d_tr(i,j,it)
       ENDDO
       ENDDO
+c
       IF (lminmax) THEN
         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc lsc')
 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
       ENDIF
+c
 c-scheme for convective scavenging
+c
 cnhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
+  EXTERNAL minmaxqfi, bcscav_spl
+  DO it=1, nbtr
+  !
+  DO j=1,klev
+  DO i=1,klon
+    aux_var1(i,j)=tr_seri(i,j,it)
+    aux_var2(i,j)=d_tr(i,j,it)
+  ENDDO
+  ENDDO
+  !
+  !nhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
+  !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
+  CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it), &
+        aux_var1,aux_var2)
+  !
+  DO j=1,klev
+  DO i=1,klon
+    tr_seri(i,j,it)=aux_var1(i,j)
+    d_tr(i,j,it)=aux_var2(i,j)
+  ENDDO
+  ENDDO
+  DO k = 1, klev
+  DO i = 1, klon
+     tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
+     his_dhbclsc(i,it)=his_dhbclsc(i,it)-d_tr(i,k,it)/RNAVO* &
+           masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys  !--mgS/m2/s
+  ENDDO
+  ENDDO
+  !
+  DO i=1,klon
+  DO j=1,klev
+    aux_var1(i,j)=tr_seri(i,j,it)
+    aux_var2(i,j)=d_tr(i,j,it)
+  ENDDO
+  ENDDO
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc lsc')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
+  ENDIF
+  !
+  !-scheme for convective scavenging
+  !
+  !nhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
+  !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
       CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
      .                aux_var1,aux_var2)
+  CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it), &
+        aux_var1,aux_var2)
+c
       DO i=1,klon
       DO j=1,klev
         tr_seri(i,j,it)=aux_var1(i,j)
         d_tr(i,j,it)=aux_var2(i,j)
       ENDDO
       ENDDO
+c
       DO k = 1, klev
       DO i = 1, klon
          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
          his_dhbccon(i,it)=his_dhbccon(i,it)-d_tr(i,k,it)/RNAVO*
      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys    !--mgS/m2/s
       ENDDO
       ENDDO
+c
       IF (lminmax) THEN
         DO j=1,klev
         DO i=1,klon
           aux_var1(i,j)=tr_seri(i,j,it)
         ENDDO
         ENDDO
         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc con')
 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
         DO j=1,klev
         DO i=1,klon
           tr_seri(i,j,it)=aux_var1(i,j)
         ENDDO
         ENDDO
       ENDIF
+c
+c
       ENDDO !--boucle sur it
+c
+      END
+  !
+  DO i=1,klon
+  DO j=1,klev
+    tr_seri(i,j,it)=aux_var1(i,j)
+    d_tr(i,j,it)=aux_var2(i,j)
+  ENDDO
+  ENDDO
+  !
+  DO k = 1, klev
+  DO i = 1, klon
+     tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
+     his_dhbccon(i,it)=his_dhbccon(i,it)-d_tr(i,k,it)/RNAVO* &
+           masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys    !--mgS/m2/s
+  ENDDO
+  ENDDO
+  !
+  IF (lminmax) THEN
+    DO j=1,klev
+    DO i=1,klon
+      aux_var1(i,j)=tr_seri(i,j,it)
+    ENDDO
+    ENDDO
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc con')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
+    DO j=1,klev
+    DO i=1,klon
+      tr_seri(i,j,it)=aux_var1(i,j)
+    ENDDO
+    ENDDO
+  ENDIF
+  !
+  !
+  ENDDO !--boucle sur it
+  !
+END SUBROUTINE blcloud_scav

LMDZ6/trunk/libf/phylmd/Dust/blcloud_scav_lsc.f90

-                      r5245
+                      r5246
 c Subroutine that calculates the effect of precipitation in scavenging
 c BELOW the cloud, for large scale as well as convective precipitation
+      SUBROUTINE blcloud_scav_lsc(lminmax,qmin,qmax,pdtphys,prfl,psfl,
      .                        pmflxr,pmflxs,zdz,alpha_r,alpha_s,masse,
      .                                  his_dhbclsc,his_dhbccon,tr_seri)
+! Subroutine that calculates the effect of precipitation in scavenging
+! BELOW the cloud, for large scale as well as convective precipitation
+SUBROUTINE blcloud_scav_lsc(lminmax,qmin,qmax,pdtphys,prfl,psfl, &
+        pmflxr,pmflxs,zdz,alpha_r,alpha_s,masse, &
+        his_dhbclsc,his_dhbccon,tr_seri)
       USE dimphy
       USE indice_sol_mod
       USE infotrac
       IMPLICIT NONE
+  USE dimphy
+  USE indice_sol_mod
+  USE infotrac
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
 c============================= INPUT ===================================
       REAL qmin,qmax
       REAL pdtphys  ! pas d'integration pour la physique (seconde)
 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
       REAL alpha_r(nbtr)!--coefficient d'impaction pour la pluie
       REAL alpha_s(nbtr)!--coefficient d'impaction pour la neige
       REAL masse(nbtr)
       LOGICAL lminmax
       REAL zdz(klon,klev)
       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
 c============================= OUTPUT ==================================
       REAL tr_seri(klon,klev,nbtr) ! traceur
       REAL aux_var1(klon,klev) ! traceur
       REAL aux_var2(klon,klev) ! traceur
       REAL his_dhbclsc(klon,nbtr), his_dhbccon(klon,nbtr)
+c========================= LOCAL VARIABLES =============================
       INTEGER it, k, i, j
       REAL d_tr(klon,klev,nbtr)
+  !============================= INPUT ===================================
+  REAL :: qmin,qmax
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+   ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+   ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+  REAL :: alpha_r(nbtr)!--coefficient d'impaction pour la pluie
+  REAL :: alpha_s(nbtr)!--coefficient d'impaction pour la neige
+  REAL :: masse(nbtr)
+  LOGICAL :: lminmax
+  REAL :: zdz(klon,klev)
+  REAL :: prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
+  REAL :: pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
+  !============================= OUTPUT ==================================
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: aux_var1(klon,klev) ! traceur
+  REAL :: aux_var2(klon,klev) ! traceur
+  REAL :: his_dhbclsc(klon,nbtr), his_dhbccon(klon,nbtr)
+  !========================= LOCAL VARIABLES =============================
+  INTEGER :: it, k, i, j
+  REAL :: d_tr(klon,klev,nbtr)
       EXTERNAL minmaxqfi, bcscav_spl
       DO it=1, nbtr
+c
       DO j=1,klev
       DO i=1,klon
         aux_var1(i,j)=tr_seri(i,j,it)
         aux_var2(i,j)=d_tr(i,j,it)
       ENDDO
       ENDDO
+c
 cnhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
       CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
      .                aux_var1,aux_var2)
+c
       DO j=1,klev
       DO i=1,klon
         tr_seri(i,j,it)=aux_var1(i,j)
         d_tr(i,j,it)=aux_var2(i,j)
       ENDDO
       ENDDO
       DO k = 1, klev
       DO i = 1, klon
          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
          his_dhbclsc(i,it)=his_dhbclsc(i,it)-d_tr(i,k,it)/RNAVO*
      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys  !--mgS/m2/s
       ENDDO
       ENDDO
+c
       DO i=1,klon
       DO j=1,klev
         aux_var1(i,j)=tr_seri(i,j,it)
         aux_var2(i,j)=d_tr(i,j,it)
       ENDDO
       ENDDO
+c
       IF (lminmax) THEN
         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc lsc')
 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
       ENDIF
+c
 c-scheme for convective scavenging
+c
 cnhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
 cnhl     .                tr_seri(1,1,it),d_tr(1,1,it))
+  EXTERNAL minmaxqfi, bcscav_spl
+  DO it=1, nbtr
+  !
+  DO j=1,klev
+  DO i=1,klon
+    aux_var1(i,j)=tr_seri(i,j,it)
+    aux_var2(i,j)=d_tr(i,j,it)
+  ENDDO
+  ENDDO
+  !
+  !nhl      CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it),
+  !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
+  CALL bcscav_spl(pdtphys,prfl,psfl,alpha_r(it),alpha_s(it), &
+        aux_var1,aux_var2)
+  !
+  DO j=1,klev
+  DO i=1,klon
+    tr_seri(i,j,it)=aux_var1(i,j)
+    d_tr(i,j,it)=aux_var2(i,j)
+  ENDDO
+  ENDDO
+  DO k = 1, klev
+  DO i = 1, klon
+     tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
+     his_dhbclsc(i,it)=his_dhbclsc(i,it)-d_tr(i,k,it)/RNAVO* &
+           masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys  !--mgS/m2/s
+  ENDDO
+  ENDDO
+  !
+  DO i=1,klon
+  DO j=1,klev
+    aux_var1(i,j)=tr_seri(i,j,it)
+    aux_var2(i,j)=d_tr(i,j,it)
+  ENDDO
+  ENDDO
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc lsc')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc lsc')
+  ENDIF
+  !
+  !-scheme for convective scavenging
+  !
+  !nhl      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
+  !nhl     .                tr_seri(1,1,it),d_tr(1,1,it))
 cJE      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
 cJE     .                aux_var1,aux_var2)
+  !JE      CALL bcscav_spl(pdtphys,pmflxr,pmflxs,alpha_r(it),alpha_s(it),
+  !JE     .                aux_var1,aux_var2)
+c
       DO i=1,klon
       DO j=1,klev
         tr_seri(i,j,it)=aux_var1(i,j)
         d_tr(i,j,it)=aux_var2(i,j)
       ENDDO
       ENDDO
+c
       DO k = 1, klev
       DO i = 1, klon
          tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
          his_dhbccon(i,it)=his_dhbccon(i,it)-d_tr(i,k,it)/RNAVO*
      .                masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys    !--mgS/m2/s
       ENDDO
       ENDDO
+c
       IF (lminmax) THEN
         DO j=1,klev
         DO i=1,klon
           aux_var1(i,j)=tr_seri(i,j,it)
         ENDDO
         ENDDO
         CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc con')
 cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
         DO j=1,klev
         DO i=1,klon
           tr_seri(i,j,it)=aux_var1(i,j)
         ENDDO
         ENDDO
       ENDIF
+c
+c
       ENDDO !--boucle sur it
+c
+      END
+  !
+  DO i=1,klon
+  DO j=1,klev
+    tr_seri(i,j,it)=aux_var1(i,j)
+    d_tr(i,j,it)=aux_var2(i,j)
+  ENDDO
+  ENDDO
+  !
+  DO k = 1, klev
+  DO i = 1, klon
+     tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k,it)
+     his_dhbccon(i,it)=his_dhbccon(i,it)-d_tr(i,k,it)/RNAVO* &
+           masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys    !--mgS/m2/s
+  ENDDO
+  ENDDO
+  !
+  IF (lminmax) THEN
+    DO j=1,klev
+    DO i=1,klon
+      aux_var1(i,j)=tr_seri(i,j,it)
+    ENDDO
+    ENDDO
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide bc con')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide bc con')
+    DO j=1,klev
+    DO i=1,klon
+      tr_seri(i,j,it)=aux_var1(i,j)
+    ENDDO
+    ENDDO
+  ENDIF
+  !
+  !
+  ENDDO !--boucle sur it
+  !
+END SUBROUTINE blcloud_scav_lsc

LMDZ6/trunk/libf/phylmd/Dust/cltrac_spl.f90

-                      r5245
+                      r5246
+      SUBROUTINE cltrac_spl(dtime,coef,yu1,yv1,t,tr,
      .                     flux,paprs,pplay,d_tr)
+SUBROUTINE cltrac_spl(dtime,coef,yu1,yv1,t,tr, &
+        flux,paprs,pplay,d_tr)
       USE dimphy
       IMPLICIT none
 c======================================================================
 c Auteur(s): O. Boucher (LOA/LMD) date: 19961127
 c            inspire de clvent
 c Objet: diffusion verticale de traceurs avec flux fixe a la surface
 c        ou/et flux du type c-drag
 c======================================================================
 c Arguments:
 c dtime----input-R- intervalle du temps (en second)
 c coef-----input-R- le coefficient d'echange (m**2/s) l>1
 c yu1------input-R- le vent dans le 1iere couche
 c yv1------input-R- le vent dans le 1iere couche
 c t--------input-R- temperature (K)
 c tr-------input-R- la q. de traceurs
 c flux-----input-R- le flux de traceurs a la surface
 c paprs----input-R- pression a inter-couche (Pa)
 c pplay----input-R- pression au milieu de couche (Pa)
 c delp-----input-R- epaisseur de couche (Pa)
 c cdrag----input-R- cdrag pour le flux de surface (non active)
 c tr0------input-R- traceurs a la surface ou dans l'ocean (non active)
 c d_tr-----output-R- le changement de tr
 c flux_tr--output-R- flux de tr
 c======================================================================
       INCLUDE "dimensions.h"
       REAL dtime
       REAL coef(klon,klev)
       REAL yu1(klon), yv1(klon)
       REAL t(klon,klev), tr(klon,klev)
       REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
       REAL d_tr(klon,klev)
       REAL flux(klon), cdrag(klon), tr0(klon)
 c      REAL flux_tr(klon,klev)
 c======================================================================
       INCLUDE "YOMCST.h"
 c======================================================================
       INTEGER i, k
       REAL zx_ctr(klon,2:klev)
       REAL zx_dtr(klon,2:klev)
       REAL zx_buf(klon)
       REAL zx_coef(klon,klev)
       REAL local_tr(klon,klev)
       REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon)
 c======================================================================
 c CHECKING VALUES
 !      print *,'CHECKING VALUES IN CLTRAC (INI)'
 !      print *,'d_tr = ',sum(d_tr),MINVAL(d_tr),MAXVAL(d_tr)
 !      print *,'flux = ',sum(flux),MINVAL(flux),MAXVAL(flux)
 !      print *,'tr = ',sum(tr),MINVAL(tr),MAXVAL(tr)
 c======================================================================
       DO k = 1, klev
       DO i = 1, klon
          local_tr(i,k) = tr(i,k)
          delp(i,k) = paprs(i,k)-paprs(i,k+1)
       ENDDO
       ENDDO
 c======================================================================
       DO i = 1, klon
          zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
          zx_alf2(i) = 1.0 - zx_alf1(i)
          zx_flux(i) =  -flux(i)*dtime*RG
 c--pour le moment le flux est prescrit
          cdrag(i) = 0.0
 c         cdrag(i) =  coef(i,1) * (1.0+SQRT(yu1(i)**2+yv1(i)**2))
 c     .                * pplay(i,1)/(RD*t(i,1))
          tr0(i) = 0.0
          zx_coef(i,1) = cdrag(i)*dtime*RG
       ENDDO
 c======================================================================
       DO k = 2, klev
       DO i = 1, klon
          zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
      .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
          zx_coef(i,k) = zx_coef(i,k)*dtime*RG
       ENDDO
       ENDDO
 c======================================================================
       DO i = 1, klon
          zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
          zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+
      .                  zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
          zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) /
      .                  zx_buf(i)
       ENDDO
+c
       DO k = 3, klev
       DO i = 1, klon
          zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
      .                  + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
          zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)
      .                  +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
          zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
       ENDDO
       ENDDO
       DO i = 1, klon
          local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev)
      .                        +zx_coef(i,klev)*zx_ctr(i,klev) )
      .                   / ( delp(i,klev) + zx_coef(i,klev)
      .                       -zx_coef(i,klev)*zx_dtr(i,klev) )
       ENDDO
       DO k = klev-1, 1, -1
       DO i = 1, klon
          local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
       ENDDO
       ENDDO
 c======================================================================
 !      print *,'CHECKING VALUES IN CLTRAC (FIN)'
 !      print *,'local_tr = ',sum(local_tr),MINVAL(local_tr),
 !     .                                    MAXVAL(local_tr)
 !      print *,'zx_ctr = ',sum(zx_ctr),MINVAL(zx_ctr),MAXVAL(zx_ctr)
 !      print *,'zx_dtr = ',sum(zx_dtr),MINVAL(zx_dtr),MAXVAL(zx_dtr)
 !      print *,'tr = ',sum(tr),MINVAL(tr),MAXVAL(tr)
 c======================================================================
 c== flux_tr est le flux de traceur (positif vers bas)
 c      DO i = 1, klon
 c         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
 c      ENDDO
 c      DO k = 2, klev
 c      DO i = 1, klon
 c         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
 c     .               * (local_tr(i,k)-local_tr(i,k-1))
 c      ENDDO
 c      ENDDO
 c======================================================================
       DO k = 1, klev
       DO i = 1, klon
          d_tr(i,k) = local_tr(i,k) - tr(i,k)
       ENDDO
       ENDDO
 !      print *,'CHECKING VALUES IN CLTRAC (END)'
 !      print *,'d_tr = ',sum(d_tr),MINVAL(d_tr),MAXVAL(d_tr)
+c
       RETURN
+      END
+  USE dimphy
+  IMPLICIT none
+  !======================================================================
+  ! Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+         ! inspire de clvent
+  ! Objet: diffusion verticale de traceurs avec flux fixe a la surface
+     ! ou/et flux du type c-drag
+  !======================================================================
+  ! Arguments:
+  ! dtime----input-R- intervalle du temps (en second)
+  ! coef-----input-R- le coefficient d'echange (m**2/s) l>1
+  ! yu1------input-R- le vent dans le 1iere couche
+  ! yv1------input-R- le vent dans le 1iere couche
+  ! t--------input-R- temperature (K)
+  ! tr-------input-R- la q. de traceurs
+  ! flux-----input-R- le flux de traceurs a la surface
+  ! paprs----input-R- pression a inter-couche (Pa)
+  ! pplay----input-R- pression au milieu de couche (Pa)
+  ! delp-----input-R- epaisseur de couche (Pa)
+  ! cdrag----input-R- cdrag pour le flux de surface (non active)
+  ! tr0------input-R- traceurs a la surface ou dans l'ocean (non active)
+  ! d_tr-----output-R- le changement de tr
+  ! flux_tr--output-R- flux de tr
+  !======================================================================
+  INCLUDE "dimensions.h"
+  REAL :: dtime
+  REAL :: coef(klon,klev)
+  REAL :: yu1(klon), yv1(klon)
+  REAL :: t(klon,klev), tr(klon,klev)
+  REAL :: paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+  REAL :: d_tr(klon,klev)
+  REAL :: flux(klon), cdrag(klon), tr0(klon)
+   ! REAL flux_tr(klon,klev)
+  !======================================================================
+  INCLUDE "YOMCST.h"
+  !======================================================================
+  INTEGER :: i, k
+  REAL :: zx_ctr(klon,2:klev)
+  REAL :: zx_dtr(klon,2:klev)
+  REAL :: zx_buf(klon)
+  REAL :: zx_coef(klon,klev)
+  REAL :: local_tr(klon,klev)
+  REAL :: zx_alf1(klon), zx_alf2(klon), zx_flux(klon)
+  !======================================================================
+  ! CHECKING VALUES
+   ! print *,'CHECKING VALUES IN CLTRAC (INI)'
+   ! print *,'d_tr = ',sum(d_tr),MINVAL(d_tr),MAXVAL(d_tr)
+   ! print *,'flux = ',sum(flux),MINVAL(flux),MAXVAL(flux)
+   ! print *,'tr = ',sum(tr),MINVAL(tr),MAXVAL(tr)
+  !======================================================================
+  DO k = 1, klev
+  DO i = 1, klon
+     local_tr(i,k) = tr(i,k)
+     delp(i,k) = paprs(i,k)-paprs(i,k+1)
+  ENDDO
+  ENDDO
+  !======================================================================
+  DO i = 1, klon
+     zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+     zx_alf2(i) = 1.0 - zx_alf1(i)
+     zx_flux(i) =  -flux(i)*dtime*RG
+  !--pour le moment le flux est prescrit
+     cdrag(i) = 0.0
+      ! cdrag(i) =  coef(i,1) * (1.0+SQRT(yu1(i)**2+yv1(i)**2))
+  ! .                * pplay(i,1)/(RD*t(i,1))
+     tr0(i) = 0.0
+     zx_coef(i,1) = cdrag(i)*dtime*RG
+  ENDDO
+  !======================================================================
+  DO k = 2, klev
+  DO i = 1, klon
+     zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+           *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+     zx_coef(i,k) = zx_coef(i,k)*dtime*RG
+  ENDDO
+  ENDDO
+  !======================================================================
+  DO i = 1, klon
+     zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+     zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+ &
+           zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+     zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / &
+           zx_buf(i)
+  ENDDO
+  !
+  DO k = 3, klev
+  DO i = 1, klon
+     zx_buf(i) = delp(i,k-1) + zx_coef(i,k) &
+           + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+     zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1) &
+           +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+     zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+  ENDDO
+  ENDDO
+  DO i = 1, klon
+     local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) &
+           +zx_coef(i,klev)*zx_ctr(i,klev) ) &
+           / ( delp(i,klev) + zx_coef(i,klev) &
+           -zx_coef(i,klev)*zx_dtr(i,klev) )
+  ENDDO
+  DO k = klev-1, 1, -1
+  DO i = 1, klon
+     local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+  ENDDO
+  ENDDO
+  !======================================================================
+   ! print *,'CHECKING VALUES IN CLTRAC (FIN)'
+   ! print *,'local_tr = ',sum(local_tr),MINVAL(local_tr),
+  ! .                                    MAXVAL(local_tr)
+  !  print *,'zx_ctr = ',sum(zx_ctr),MINVAL(zx_ctr),MAXVAL(zx_ctr)
+  !  print *,'zx_dtr = ',sum(zx_dtr),MINVAL(zx_dtr),MAXVAL(zx_dtr)
+  !  print *,'tr = ',sum(tr),MINVAL(tr),MAXVAL(tr)
+  !======================================================================
+  !== flux_tr est le flux de traceur (positif vers bas)
+  !  DO i = 1, klon
+  !     flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+  !  ENDDO
+  !  DO k = 2, klev
+  !  DO i = 1, klon
+  !     flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+  ! .               * (local_tr(i,k)-local_tr(i,k-1))
+  !  ENDDO
+  !  ENDDO
+  !======================================================================
+  DO k = 1, klev
+  DO i = 1, klon
+     d_tr(i,k) = local_tr(i,k) - tr(i,k)
+  ENDDO
+  ENDDO
+   ! print *,'CHECKING VALUES IN CLTRAC (END)'
+   ! print *,'d_tr = ',sum(d_tr),MINVAL(d_tr),MAXVAL(d_tr)
+  !
+  RETURN
+END SUBROUTINE cltrac_spl

LMDZ6/trunk/libf/phylmd/Dust/cm3_to_kg.f90

-                      r5245
+                      r5246
       SUBROUTINE cm3_to_kg(pplay,t_seri,tr_seri)
+SUBROUTINE cm3_to_kg(pplay,t_seri,tr_seri)
       USE dimphy
       USE infotrac
       USE indice_sol_mod
+  USE dimphy
+  USE infotrac
+  USE indice_sol_mod
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "YOMCST.h"
+c
       REAL t_seri(klon,klev), pplay(klon,klev)
       REAL tr_seri(klon,klev)
       REAL zrho
       INTEGER i, k
+c
 !JE20150707      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
       DO k = 1, klev
       DO i = 1, klon
         zrho=pplay(i,k)/t_seri(i,k)/RD
         tr_seri(i,k)=tr_seri(i,k)*1.e6/zrho
       ENDDO
       ENDDO
+c
+      END
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "YOMCST.h"
+  !
+  REAL :: t_seri(klon,klev), pplay(klon,klev)
+  REAL :: tr_seri(klon,klev)
+  REAL :: zrho
+  INTEGER :: i, k
+  !
+  !JE20150707      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+  DO k = 1, klev
+  DO i = 1, klon
+    zrho=pplay(i,k)/t_seri(i,k)/RD
+    tr_seri(i,k)=tr_seri(i,k)*1.e6/zrho
+  ENDDO
+  ENDDO
+  !
+END SUBROUTINE cm3_to_kg

LMDZ6/trunk/libf/phylmd/Dust/coarsemission.f90

-                      r5245
+                      r5246
 c This subroutine calculates the emissions of SEA SALT and DUST, part of
 C which goes to tracer 2 and other part to tracer 3.
+      SUBROUTINE coarsemission(pctsrf,pdtphys,
      .                         t_seri,pmflxr,pmflxs,prfl,psfl,
      .                         xlat,xlon,debutphy,
      .                         zu10m,zv10m,wstar,ale_bl,ale_wake,
      .                         scale_param_ssacc,scale_param_sscoa,
      .                         scale_param_dustacc,scale_param_dustcoa,
      .                         scale_param_dustsco,
      .                         nbreg_dust,
      .                         iregion_dust,dust_ec,
      .                  param_wstarBLperregion,param_wstarWAKEperregion,
      .                  nbreg_wstardust,
      .                  iregion_wstardust,
      .                         lmt_sea_salt,qmin,qmax,
      .                             flux_sparam_ddfine,flux_sparam_ddcoa,
      .                             flux_sparam_ddsco,
      .                             flux_sparam_ssfine,flux_sparam_sscoa,
      .                          id_prec,id_fine,id_coss,id_codu,id_scdu,
      .                          ok_chimeredust,
      .                                                source_tr,flux_tr)
 !     .                         wth,cly,zprecipinsoil,lmt_sea_salt,
+!      CALL dustemission( debutphy, xlat, xlon, pctsrf,
 !     .               zu10m     zv10m,wstar,ale_bl,ale_wake)
+!
       USE dimphy
       USE indice_sol_mod
       USE infotrac
       USE dustemission_mod,  ONLY : dustemission
 !      USE phytracr_spl_mod, ONLY : nbreg_dust, nbreg_ind, nbreg_bb
       IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "chem_spla.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
 c============================== INPUT ==================================
       INTEGER nbjour
       LOGICAL ok_chimeredust
       REAL pdtphys  ! pas d'integration pour la physique (seconde)
       REAL t_seri(klon,klev)  ! temperature
       REAL pctsrf(klon,nbsrf)
       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
 !      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
       REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
 !      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
       LOGICAL debutphy, lafinphy
       REAL, intent(in) ::  xlat(klon)    ! latitudes pour chaque point
       REAL, intent(in) ::  xlon(klon)    ! longitudes pour chaque point
       REAL,DIMENSION(klon),INTENT(IN)    :: zu10m
       REAL,DIMENSION(klon),INTENT(IN)    :: zv10m
       REAL,DIMENSION(klon),INTENT(IN)    :: wstar,Ale_bl,ale_wake
+c
 c------------------------- Scaling Parameters --------------------------
+c
       INTEGER iregion_dust(klon) !Defines  dust regions
       REAL scale_param_ssacc  !Scaling parameter for Fine Sea Salt
       REAL scale_param_sscoa  !Scaling parameter for Coarse Sea Salt
       REAL scale_param_dustacc(nbreg_dust)  !Scaling parameter for Fine Dust
       REAL scale_param_dustcoa(nbreg_dust)  !Scaling parameter for Coarse Dust
       REAL scale_param_dustsco(nbreg_dust)  !Scaling parameter for SCoarse Dust
 !JE20141124<<
       INTEGER iregion_wstardust(klon) !Defines dust regions in terms of wstar
       REAL param_wstarBLperregion(nbreg_wstardust)  !
       REAL param_wstarWAKEperregion(nbreg_wstardust)  !
       REAL param_wstarBL(klon)  !parameter for surface wind correction..
       REAL param_wstarWAKE(klon)  !parameter for surface wind correction..
       INTEGER  nbreg_wstardust
 !JE20141124>>
       INTEGER  nbreg_dust
       INTEGER, INTENT(IN) :: id_prec,id_fine,id_coss,id_codu,id_scdu
 c============================== OUTPUT =================================
       REAL source_tr(klon,nbtr)
       REAL flux_tr(klon,nbtr)
       REAL flux_sparam_ddfine(klon), flux_sparam_ddcoa(klon)
       REAL flux_sparam_ddsco(klon)
       REAL flux_sparam_ssfine(klon), flux_sparam_sscoa(klon)
+c=========================== LOCAL VARIABLES ===========================
       INTEGER i, j
       REAL pct_ocean(klon)
 !      REAL zprecipinsoil(klon)
 !      REAL cly(klon), wth(klon)
       REAL clyfac, avgdryrate, drying
 c---------------------------- SEA SALT emissions ------------------------
       REAL lmt_sea_salt(klon,ss_bins) !Sea salt 0.03-8.0 um
+c
 c--------vent 10 m CEPMMT
+c
       REAL dust_ec(klon)
       real tmp_var2(klon,nbtr) ! auxiliary variable to replace source
       REAL qmin, qmax
 !----------------------DUST Sahara ---------------
       REAL, DIMENSION(klon) :: dustsourceacc,dustsourcecoa,dustsourcesco
       INTEGER, DIMENSION(klon) :: maskd
 C*********************** DUST EMMISSIONS *******************************
+c
 !     avgdryrate=300./365.*pdtphys/86400.
+c
 !     DO i=1, klon
+c
 !       IF (cly(i).LT.9990..AND.wth(i).LT.9990.) THEN
 !        zprecipinsoil(i)=zprecipinsoil(i) +
 !    .        (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
+c
 !        clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
 !        drying=avgdryrate*exp(0.03905491*
 !    .                    exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
 !        zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
+c
 !       ENDIF
+c
 !     ENDDO
+c
 c ==================== CALCULATING DUST EMISSIONS ======================
+c
 !      IF (lminmax) THEN
       DO j=1,nbtr
       DO i=1,klon
          tmp_var2(i,j)=source_tr(i,j)
       ENDDO
       ENDDO
       CALL minmaxsource(tmp_var2,qmin,qmax,'src: before DD emiss')
 !      print *,'Source = ',SUM(source_tr),MINVAL(source_tr),
 !     .                                     MAXVAL(source_tr)
 !      ENDIF
+c
       IF (.NOT. ok_chimeredust)  THEN
       DO i=1, klon
 !!     IF (cly(i).GE.9990..OR.wth(i).GE.9990..OR.
 !!    .    t_seri(i,1).LE.273.15.OR.zprecipinsoil(i).GT.1.e-8) THEN
 !!          dust_ec(i)=0.0
 !!     ENDIF
+!c Corresponds to dust_emission.EQ.3
 !!!!!!!****************AQUIIIIIIIIIIIIIIIIIIIIIIIIIIII
 !! Original line (4 tracers)
 !JE<<  old 4 tracer(nhl scheme)        source_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
 !     .                  dust_ec(i)*1.e3*0.093   ! g/m2/s
 !         source_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
 !     .                  dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
 !! Original line (4 tracers)
 !         flux_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
 !     .                  dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
 !         flux_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
 !     .                  dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
 !         flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
 !     .                            dust_ec(i)*1.e3*0.093*1.e3
 !         flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
 !     .                            dust_ec(i)*1.e3*0.905*1.e3
       IF(id_fine>0)     source_tr(i,id_fine)=
      . scale_param_dustacc(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.093   ! g/m2/s
       IF(id_codu>0)   source_tr(i,id_codu)=
      . scale_param_dustcoa(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
       IF(id_scdu>0)  source_tr(i,id_scdu)=0.   ! no supercoarse
 ! Original line (4 tracers)
        IF(id_fine>0)   flux_tr(i,id_fine)=
      .  scale_param_dustacc(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
        IF(id_codu>0)  flux_tr(i,id_codu)=
      . scale_param_dustcoa(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
        IF(id_scdu>0) flux_tr(i,id_scdu)=0.
          flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
      .                            dust_ec(i)*1.e3*0.093*1.e3
          flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
      .                            dust_ec(i)*1.e3*0.905*1.e3
          flux_sparam_ddsco(i)=0.
       ENDDO
       ENDIF
 !*****************NEW CHIMERE DUST EMISSION Sahara*****
 ! je  20140522
       IF(ok_chimeredust) THEN
       print *,'MIX- NEW SAHARA DUST SOURCE SCHEME...'
       DO i=1,klon
       param_wstarBL(i)  =param_wstarBLperregion(iregion_wstardust(i))
       param_wstarWAKE(i)=param_wstarWAKEperregion(iregion_wstardust(i))
       ENDDO
       CALL dustemission( debutphy, xlat, xlon, pctsrf,
      .                  zu10m,zv10m,wstar,ale_bl,ale_wake,
      .                  param_wstarBL, param_wstarWAKE,
      .                  dustsourceacc,dustsourcecoa,
      .                  dustsourcesco,maskd)
       DO i=1,klon
          if (maskd(i).gt.0) then
       IF(id_fine>0)    source_tr(i,id_fine)=
      . scale_param_dustacc(iregion_dust(i))*
      .                  dustsourceacc(i)*1.e3   ! g/m2/s  bin 0.03-0.5
       IF(id_codu>0)    source_tr(i,id_codu)=
      . scale_param_dustcoa(iregion_dust(i))*
      .                  dustsourcecoa(i)*1.e3   ! g/m2/s   bin 0.5-3um
       IF(id_scdu>0)   source_tr(i,id_scdu)=
      . scale_param_dustsco(iregion_dust(i))*
      .                  dustsourcesco(i)*1.e3   ! g/m2/s   bin 3-15um
 ! Original line (4 tracers)
        IF(id_fine>0)  flux_tr(i,id_fine)=
      .  scale_param_dustacc(iregion_dust(i))*
      .                  dustsourceacc(i)*1.e3*1.e3  !mg/m2/s
        IF(id_codu>0)  flux_tr(i,id_codu)=
      . scale_param_dustcoa(iregion_dust(i))*
      .                  dustsourcecoa(i)*1.e3*1.e3  !mg/m2/s bin 0.5-3um
        IF(id_scdu>0)  flux_tr(i,id_scdu)=
      . scale_param_dustsco(iregion_dust(i))*
      .                  dustsourcesco(i)*1.e3*1.e3  !mg/m2/s bin 3-15um
          flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
      .                            dustsourceacc(i)*1.e3*1.e3
          flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
      .                            dustsourcecoa(i)*1.e3*1.e3
          flux_sparam_ddsco(i)=scale_param_dustsco(iregion_dust(i)) *
      .                            dustsourcesco(i)*1.e3*1.e3
          else
         IF(id_fine>0) source_tr(i,id_fine)=
      .  scale_param_dustacc(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.114   ! g/m2/s
         IF(id_codu>0) source_tr(i,id_codu)=
      .  scale_param_dustcoa(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.108   ! g/m2/s   bin 0.5-3um
         IF(id_scdu>0) source_tr(i,id_scdu)=
      .  scale_param_dustsco(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.778   ! g/m2/s   bin 3-15um
 ! Original line (4 tracers)
         IF(id_fine>0) flux_tr(i,id_fine)=
      . scale_param_dustacc(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.114*1.e3  !mg/m2/s
         IF(id_codu>0) flux_tr(i,id_codu)=
      . scale_param_dustcoa(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.108*1.e3  !mg/m2/s bin 0.5-3um
         IF(id_scdu>0) flux_tr(i,id_scdu)=
      . scale_param_dustsco(iregion_dust(i))*
      .                  dust_ec(i)*1.e3*0.778*1.e3  !mg/m2/s bin 0.5-3um
          flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
      .                            dust_ec(i)*1.e3*0.114*1.e3
          flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
      .                            dust_ec(i)*1.e3*0.108*1.e3
          flux_sparam_ddsco(i)=scale_param_dustsco(iregion_dust(i)) *
      .                            dust_ec(i)*1.e3*0.778*1.e3
          endif
       ENDDO
       ENDIF
+!*****************************************************
 C******************* SEA SALT EMMISSIONS *******************************
       DO i=1,klon
          pct_ocean(i)=pctsrf(i,is_oce)
       ENDDO
+c
 !      IF (lminmax) THEN
       DO j=1,nbtr
       DO i=1,klon
          tmp_var2(i,j)=source_tr(i,j)
       ENDDO
       ENDDO
       CALL minmaxsource(tmp_var2,qmin,qmax,'src: before SS emiss')
       IF(id_coss>0) then
       print *,'Source = ',SUM(source_tr(:,id_coss)),
      .     MINVAL(source_tr(:,id_coss)), MAXVAL(source_tr(:,id_coss))
       ENDIF
+!
       DO i=1,klon
 ! Original line (4 tracers)
          IF(id_fine>0) source_tr(i,id_fine)=
      . source_tr(i,id_fine)+scale_param_ssacc*
      .                                 lmt_sea_salt(i,1)*1.e4       !g/m2/s
 ! Original line (4 tracers)
        IF(id_fine>0)  flux_tr(i,id_fine)=
      . flux_tr(i,id_fine)+scale_param_ssacc
      .                            *lmt_sea_salt(i,1)*1.e4*1.e3      !mg/m2/s
+!
       IF(id_coss>0)  source_tr(i,id_coss)=
      . scale_param_sscoa*lmt_sea_salt(i,2)*1.e4    !g/m2/s
       IF(id_coss>0)  flux_tr(i,id_coss)=
      . scale_param_sscoa*lmt_sea_salt(i,2)*1.e4*1.e3 !mg/m2/s
+c
          flux_sparam_ssfine(i)=scale_param_ssacc *
      .                                  lmt_sea_salt(i,1)*1.e4*1.e3
          flux_sparam_sscoa(i)=scale_param_sscoa *
      .                                  lmt_sea_salt(i,2)*1.e4*1.e3
       ENDDO
 !      IF (lminmax) THEN
       DO j=1,nbtr
       DO i=1,klon
          tmp_var2(i,j)=source_tr(i,j)
       ENDDO
       ENDDO
       CALL minmaxsource(tmp_var2,qmin,qmax,'src: after SS emiss')
       IF(id_coss>0) then
       print *,'Source = ',SUM(source_tr(:,id_coss)),
      .  MINVAL(source_tr(:,id_coss)), MAXVAL(source_tr(:,id_coss))
       ENDIF
+c
+      END
+! This subroutine calculates the emissions of SEA SALT and DUST, part of
+! which goes to tracer 2 and other part to tracer 3.
+SUBROUTINE coarsemission(pctsrf,pdtphys, &
+        t_seri,pmflxr,pmflxs,prfl,psfl, &
+        xlat,xlon,debutphy, &
+        zu10m,zv10m,wstar,ale_bl,ale_wake, &
+        scale_param_ssacc,scale_param_sscoa, &
+        scale_param_dustacc,scale_param_dustcoa, &
+        scale_param_dustsco, &
+        nbreg_dust, &
+        iregion_dust,dust_ec, &
+        param_wstarBLperregion,param_wstarWAKEperregion, &
+        nbreg_wstardust, &
+        iregion_wstardust, &
+        lmt_sea_salt,qmin,qmax, &
+        flux_sparam_ddfine,flux_sparam_ddcoa, &
+        flux_sparam_ddsco, &
+        flux_sparam_ssfine,flux_sparam_sscoa, &
+        id_prec,id_fine,id_coss,id_codu,id_scdu, &
+        ok_chimeredust, &
+        source_tr,flux_tr)
+  ! .                         wth,cly,zprecipinsoil,lmt_sea_salt,
+  !  CALL dustemission( debutphy, xlat, xlon, pctsrf,
+  ! .               zu10m     zv10m,wstar,ale_bl,ale_wake)
+  !
+  USE dimphy
+  USE indice_sol_mod
+  USE infotrac
+  USE dustemission_mod,  ONLY : dustemission
+   ! USE phytracr_spl_mod, ONLY : nbreg_dust, nbreg_ind, nbreg_bb
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "chem_spla.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
+  !============================== INPUT ==================================
+  INTEGER :: nbjour
+  LOGICAL :: ok_chimeredust
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+  REAL :: t_seri(klon,klev)  ! temperature
+  REAL :: pctsrf(klon,nbsrf)
+  REAL :: pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
+   ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+  REAL :: prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
+   ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+  LOGICAL :: debutphy, lafinphy
+  REAL, intent(in) ::  xlat(klon)    ! latitudes pour chaque point
+  REAL, intent(in) ::  xlon(klon)    ! longitudes pour chaque point
+  REAL,DIMENSION(klon),INTENT(IN)    :: zu10m
+  REAL,DIMENSION(klon),INTENT(IN)    :: zv10m
+  REAL,DIMENSION(klon),INTENT(IN)    :: wstar,Ale_bl,ale_wake
+  !
+  !------------------------- Scaling Parameters --------------------------
+  !
+  INTEGER :: iregion_dust(klon) !Defines  dust regions
+  REAL :: scale_param_ssacc  !Scaling parameter for Fine Sea Salt
+  REAL :: scale_param_sscoa  !Scaling parameter for Coarse Sea Salt
+  REAL :: scale_param_dustacc(nbreg_dust)  !Scaling parameter for Fine Dust
+  REAL :: scale_param_dustcoa(nbreg_dust)  !Scaling parameter for Coarse Dust
+  REAL :: scale_param_dustsco(nbreg_dust)  !Scaling parameter for SCoarse Dust
+  !JE20141124<<
+  INTEGER :: iregion_wstardust(klon) !Defines dust regions in terms of wstar
+  REAL :: param_wstarBLperregion(nbreg_wstardust)  !
+  REAL :: param_wstarWAKEperregion(nbreg_wstardust)  !
+  REAL :: param_wstarBL(klon)  !parameter for surface wind correction..
+  REAL :: param_wstarWAKE(klon)  !parameter for surface wind correction..
+  INTEGER :: nbreg_wstardust
+  !JE20141124>>
+  INTEGER :: nbreg_dust
+  INTEGER, INTENT(IN) :: id_prec,id_fine,id_coss,id_codu,id_scdu
+  !============================== OUTPUT =================================
+  REAL :: source_tr(klon,nbtr)
+  REAL :: flux_tr(klon,nbtr)
+  REAL :: flux_sparam_ddfine(klon), flux_sparam_ddcoa(klon)
+  REAL :: flux_sparam_ddsco(klon)
+  REAL :: flux_sparam_ssfine(klon), flux_sparam_sscoa(klon)
+  !=========================== LOCAL VARIABLES ===========================
+  INTEGER :: i, j
+  REAL :: pct_ocean(klon)
+   ! REAL zprecipinsoil(klon)
+   ! REAL cly(klon), wth(klon)
+  REAL :: clyfac, avgdryrate, drying
+  !---------------------------- SEA SALT emissions ------------------------
+  REAL :: lmt_sea_salt(klon,ss_bins) !Sea salt 0.03-8.0 um
+  !
+  !--------vent 10 m CEPMMT
+  !
+  REAL :: dust_ec(klon)
+  real :: tmp_var2(klon,nbtr) ! auxiliary variable to replace source
+  REAL :: qmin, qmax
+  !----------------------DUST Sahara ---------------
+  REAL, DIMENSION(klon) :: dustsourceacc,dustsourcecoa,dustsourcesco
+  INTEGER, DIMENSION(klon) :: maskd
+  !*********************** DUST EMMISSIONS *******************************
+  !
+  ! avgdryrate=300./365.*pdtphys/86400.
+  !
+  ! DO i=1, klon
+  !
+  !   IF (cly(i).LT.9990..AND.wth(i).LT.9990.) THEN
+  !    zprecipinsoil(i)=zprecipinsoil(i) +
+  !    .        (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
+  !
+  !    clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
+  !    drying=avgdryrate*exp(0.03905491*
+  !    .                    exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
+  !    zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
+  !
+  !   ENDIF
+  !
+  ! ENDDO
+  !
+  ! ==================== CALCULATING DUST EMISSIONS ======================
+  !
+  !  IF (lminmax) THEN
+  DO j=1,nbtr
+  DO i=1,klon
+     tmp_var2(i,j)=source_tr(i,j)
+  ENDDO
+  ENDDO
+  CALL minmaxsource(tmp_var2,qmin,qmax,'src: before DD emiss')
+   ! print *,'Source = ',SUM(source_tr),MINVAL(source_tr),
+  ! .                                     MAXVAL(source_tr)
+  !  ENDIF
+  !
+  IF (.NOT. ok_chimeredust)  THEN
+  DO i=1, klon
+  !!     IF (cly(i).GE.9990..OR.wth(i).GE.9990..OR.
+  !!    .    t_seri(i,1).LE.273.15.OR.zprecipinsoil(i).GT.1.e-8) THEN
+  !!          dust_ec(i)=0.0
+  !!     ENDIF
+  !c Corresponds to dust_emission.EQ.3
+  !!!!!!!****************AQUIIIIIIIIIIIIIIIIIIIIIIIIIIII
+  !! Original line (4 tracers)
+  !JE<<  old 4 tracer(nhl scheme)        source_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
+  ! .                  dust_ec(i)*1.e3*0.093   ! g/m2/s
+  !     source_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
+  ! .                  dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
+  !! Original line (4 tracers)
+  !     flux_tr(i,id_fine)=scale_param_dustacc(iregion_dust(i))*
+  ! .                  dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
+  !     flux_tr(i,id_codu)=scale_param_dustcoa(iregion_dust(i))*
+  ! .                  dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
+  !     flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) *
+  ! .                            dust_ec(i)*1.e3*0.093*1.e3
+  !     flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) *
+  ! .                            dust_ec(i)*1.e3*0.905*1.e3
+  IF(id_fine>0)     source_tr(i,id_fine)= &
+        scale_param_dustacc(iregion_dust(i))* &
+        dust_ec(i)*1.e3*0.093   ! g/m2/s
+  IF(id_codu>0)   source_tr(i,id_codu)= &
+        scale_param_dustcoa(iregion_dust(i))* &
+        dust_ec(i)*1.e3*0.905   ! g/m2/s   bin 0.5-10um
+  IF(id_scdu>0)  source_tr(i,id_scdu)=0.   ! no supercoarse
+  ! Original line (4 tracers)
+   IF(id_fine>0)   flux_tr(i,id_fine)= &
+         scale_param_dustacc(iregion_dust(i))* &
+         dust_ec(i)*1.e3*0.093*1.e3  !mg/m2/s
+   IF(id_codu>0)  flux_tr(i,id_codu)= &
+         scale_param_dustcoa(iregion_dust(i))* &
+         dust_ec(i)*1.e3*0.905*1.e3  !mg/m2/s bin 0.5-10um
+   IF(id_scdu>0) flux_tr(i,id_scdu)=0.
+     flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) * &
+           dust_ec(i)*1.e3*0.093*1.e3
+     flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) * &
+           dust_ec(i)*1.e3*0.905*1.e3
+     flux_sparam_ddsco(i)=0.
+  ENDDO
+  ENDIF
+  !*****************NEW CHIMERE DUST EMISSION Sahara*****
+  ! je  20140522
+  IF(ok_chimeredust) THEN
+  print *,'MIX- NEW SAHARA DUST SOURCE SCHEME...'
+  DO i=1,klon
+  param_wstarBL(i)  =param_wstarBLperregion(iregion_wstardust(i))
+  param_wstarWAKE(i)=param_wstarWAKEperregion(iregion_wstardust(i))
+  ENDDO
+  CALL dustemission( debutphy, xlat, xlon, pctsrf, &
+        zu10m,zv10m,wstar,ale_bl,ale_wake, &
+        param_wstarBL, param_wstarWAKE, &
+        dustsourceacc,dustsourcecoa, &
+        dustsourcesco,maskd)
+  DO i=1,klon
+     if (maskd(i).gt.0) then
+  IF(id_fine>0)    source_tr(i,id_fine)= &
+        scale_param_dustacc(iregion_dust(i))* &
+        dustsourceacc(i)*1.e3   ! g/m2/s  bin 0.03-0.5
+  IF(id_codu>0)    source_tr(i,id_codu)= &
+        scale_param_dustcoa(iregion_dust(i))* &
+        dustsourcecoa(i)*1.e3   ! g/m2/s   bin 0.5-3um
+  IF(id_scdu>0)   source_tr(i,id_scdu)= &
+        scale_param_dustsco(iregion_dust(i))* &
+        dustsourcesco(i)*1.e3   ! g/m2/s   bin 3-15um
+  ! Original line (4 tracers)
+   IF(id_fine>0)  flux_tr(i,id_fine)= &
+         scale_param_dustacc(iregion_dust(i))* &
+         dustsourceacc(i)*1.e3*1.e3  !mg/m2/s
+   IF(id_codu>0)  flux_tr(i,id_codu)= &
+         scale_param_dustcoa(iregion_dust(i))* &
+         dustsourcecoa(i)*1.e3*1.e3  !mg/m2/s bin 0.5-3um
+   IF(id_scdu>0)  flux_tr(i,id_scdu)= &
+         scale_param_dustsco(iregion_dust(i))* &
+         dustsourcesco(i)*1.e3*1.e3  !mg/m2/s bin 3-15um
+     flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) * &
+           dustsourceacc(i)*1.e3*1.e3
+     flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) * &
+           dustsourcecoa(i)*1.e3*1.e3
+     flux_sparam_ddsco(i)=scale_param_dustsco(iregion_dust(i)) * &
+           dustsourcesco(i)*1.e3*1.e3
+     else
+    IF(id_fine>0) source_tr(i,id_fine)= &
+          scale_param_dustacc(iregion_dust(i))* &
+          dust_ec(i)*1.e3*0.114   ! g/m2/s
+    IF(id_codu>0) source_tr(i,id_codu)= &
+          scale_param_dustcoa(iregion_dust(i))* &
+          dust_ec(i)*1.e3*0.108   ! g/m2/s   bin 0.5-3um
+    IF(id_scdu>0) source_tr(i,id_scdu)= &
+          scale_param_dustsco(iregion_dust(i))* &
+          dust_ec(i)*1.e3*0.778   ! g/m2/s   bin 3-15um
+  ! Original line (4 tracers)
+    IF(id_fine>0) flux_tr(i,id_fine)= &
+          scale_param_dustacc(iregion_dust(i))* &
+          dust_ec(i)*1.e3*0.114*1.e3  !mg/m2/s
+    IF(id_codu>0) flux_tr(i,id_codu)= &
+          scale_param_dustcoa(iregion_dust(i))* &
+          dust_ec(i)*1.e3*0.108*1.e3  !mg/m2/s bin 0.5-3um
+    IF(id_scdu>0) flux_tr(i,id_scdu)= &
+          scale_param_dustsco(iregion_dust(i))* &
+          dust_ec(i)*1.e3*0.778*1.e3  !mg/m2/s bin 0.5-3um
+     flux_sparam_ddfine(i)=scale_param_dustacc(iregion_dust(i)) * &
+           dust_ec(i)*1.e3*0.114*1.e3
+     flux_sparam_ddcoa(i)=scale_param_dustcoa(iregion_dust(i)) * &
+           dust_ec(i)*1.e3*0.108*1.e3
+     flux_sparam_ddsco(i)=scale_param_dustsco(iregion_dust(i)) * &
+           dust_ec(i)*1.e3*0.778*1.e3
+     endif
+  ENDDO
+  ENDIF
+  !*****************************************************
+  !******************* SEA SALT EMMISSIONS *******************************
+  DO i=1,klon
+     pct_ocean(i)=pctsrf(i,is_oce)
+  ENDDO
+  !
+  !  IF (lminmax) THEN
+  DO j=1,nbtr
+  DO i=1,klon
+     tmp_var2(i,j)=source_tr(i,j)
+  ENDDO
+  ENDDO
+  CALL minmaxsource(tmp_var2,qmin,qmax,'src: before SS emiss')
+  IF(id_coss>0) then
+  print *,'Source = ',SUM(source_tr(:,id_coss)), &
+        MINVAL(source_tr(:,id_coss)), MAXVAL(source_tr(:,id_coss))
+  ENDIF
+  !
+  DO i=1,klon
+  ! Original line (4 tracers)
+     IF(id_fine>0) source_tr(i,id_fine)= &
+           source_tr(i,id_fine)+scale_param_ssacc* &
+           lmt_sea_salt(i,1)*1.e4       !g/m2/s
+  ! Original line (4 tracers)
+   IF(id_fine>0)  flux_tr(i,id_fine)= &
+         flux_tr(i,id_fine)+scale_param_ssacc &
+         *lmt_sea_salt(i,1)*1.e4*1.e3      !mg/m2/s
+  !
+  IF(id_coss>0)  source_tr(i,id_coss)= &
+        scale_param_sscoa*lmt_sea_salt(i,2)*1.e4    !g/m2/s
+  IF(id_coss>0)  flux_tr(i,id_coss)= &
+        scale_param_sscoa*lmt_sea_salt(i,2)*1.e4*1.e3 !mg/m2/s
+  !
+     flux_sparam_ssfine(i)=scale_param_ssacc * &
+           lmt_sea_salt(i,1)*1.e4*1.e3
+     flux_sparam_sscoa(i)=scale_param_sscoa * &
+           lmt_sea_salt(i,2)*1.e4*1.e3
+  ENDDO
+   ! IF (lminmax) THEN
+  DO j=1,nbtr
+  DO i=1,klon
+     tmp_var2(i,j)=source_tr(i,j)
+  ENDDO
+  ENDDO
+  CALL minmaxsource(tmp_var2,qmin,qmax,'src: after SS emiss')
+  IF(id_coss>0) then
+  print *,'Source = ',SUM(source_tr(:,id_coss)), &
+        MINVAL(source_tr(:,id_coss)), MAXVAL(source_tr(:,id_coss))
+  ENDIF
+  !
+END SUBROUTINE coarsemission

LMDZ6/trunk/libf/phylmd/Dust/condsurfc.f90

-                      r5245
+                      r5246
+      SUBROUTINE condsurfc(jour,lmt_bcff,lmt_bcbb,
      .                     lmt_bcbbl,lmt_bcbbh,lmt_bc_penner,
      .                     lmt_omff,lmt_ombb,lmt_ombbl,lmt_ombbh,
      .                     lmt_omnat)
       USE dimphy
       IMPLICIT none
+!
 ! Lire les conditions aux limites du modele pour la chimie.
 ! --------------------------------------------------------
+!
       INCLUDE "dimensions.h"
       INCLUDE "netcdf.inc"
       REAL lmt_bcff(klon), lmt_bcbb(klon),lmt_bc_penner(klon)
       REAL lmt_omff(klon), lmt_ombb(klon)
       REAL lmt_bcbbl(klon), lmt_bcbbh(klon)
       REAL lmt_ombbl(klon), lmt_ombbh(klon)
       REAL lmt_omnat(klon)
       REAL lmt_terp(klon)
+!
       INTEGER jour, i
       INTEGER ierr
       INTEGER nid1,nvarid
       INTEGER debut(2),epais(2)
+!
       IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
          IF (jour.GT.(360-1).AND.jour.LE.367) THEN
            jour=360-1
            print *,'JE: jour changed to jour= ',jour
          ELSE
            PRINT*,'Le jour demande n est pas correcte:', jour
            CALL ABORT
          ENDIF
       ENDIF
+!
       ierr = NF_OPEN ("limitcarbon.nc", NF_NOWRITE, nid1)
       if (ierr.ne.NF_NOERR) then
         write(6,*)' Pb d''ouverture du fichier limitbc.nc'
         write(6,*)' ierr = ', ierr
         call exit(1)
       endif
+!
 ! Tranche a lire:
       debut(1) = 1
       debut(2) = jour+1
       epais(1) = klon
       epais(2) = 1
+!
+!
       ierr = NF_INQ_VARID (nid1, "BCFF", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcff)
 !      print *,'IERR = ',ierr
 !      print *,'NF_NOERR = ',NF_NOERR
 !      print *,'debut = ',debut
 !      print *,'epais = ',epais
 !nhl #else
 !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcff)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC'
          CALL exit(1)
       ENDIF
+!
+!
       ierr = NF_INQ_VARID (nid1, "BCBB", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcbb)
 !nhl #else
 !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcbb)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC-biomass'
          CALL exit(1)
       ENDIF
+!
+!
       ierr = NF_INQ_VARID (nid1, "BCBL", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcbbl)
 !nhl #else
 !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcbbl)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC low'
          CALL exit(1)
       ENDIF
+!
+!
       ierr = NF_INQ_VARID (nid1, "BCBH", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcbbh)
 !nhl #else
 !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcbbh)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC high'
          CALL exit(1)
       ENDIF
+!
       ierr = NF_INQ_VARID (nid1, "TERP", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_terp)
 !nhl #else
 !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_terp)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources Terpene'
          CALL exit(1)
       ENDIF
+!
+!
       ierr = NF_INQ_VARID (nid1, "BC_penner", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut,
      .       epais, lmt_bc_penner)
 !nhl #else
+!nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais,
 !nhl      .       lmt_bc_penner)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC Penner'
          CALL exit(1)
       ENDIF
+!
+!
       ierr = NF_INQ_VARID (nid1, "OMFF", nvarid)
 !nhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_omff)
 !nhl #else
 !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_omff)
 !nhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources om-ifossil'
          CALL exit(1)
       ENDIF
+!
       DO i=1,klon
         lmt_ombb(i)  = lmt_bcbb(i)*7.0*1.6      !OC/BC=7.0;OM/OC=1.6
         lmt_ombbl(i) = lmt_bcbbl(i)*7.0*1.6
         lmt_ombbh(i) = lmt_bcbbh(i)*7.0*1.6
         lmt_omff(i)  = lmt_omff(i)*1.4          !--OM/OC=1.4
         lmt_omnat(i)  = lmt_terp(i)*0.11*1.4 !-- 11% Terpene is OC
       ENDDO
+!
       ierr = NF_CLOSE(nid1)
       PRINT*, 'Carbon sources lues pour jour: ', jour
+!
       RETURN
+      END
+SUBROUTINE condsurfc(jour,lmt_bcff,lmt_bcbb, &
+        lmt_bcbbl,lmt_bcbbh,lmt_bc_penner, &
+        lmt_omff,lmt_ombb,lmt_ombbl,lmt_ombbh, &
+        lmt_omnat)
+  USE dimphy
+  IMPLICIT none
+  !
+  ! Lire les conditions aux limites du modele pour la chimie.
+  ! --------------------------------------------------------
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "netcdf.inc"
+  REAL :: lmt_bcff(klon), lmt_bcbb(klon),lmt_bc_penner(klon)
+  REAL :: lmt_omff(klon), lmt_ombb(klon)
+  REAL :: lmt_bcbbl(klon), lmt_bcbbh(klon)
+  REAL :: lmt_ombbl(klon), lmt_ombbh(klon)
+  REAL :: lmt_omnat(klon)
+  REAL :: lmt_terp(klon)
+  !
+  INTEGER :: jour, i
+  INTEGER :: ierr
+  INTEGER :: nid1,nvarid
+  INTEGER :: debut(2),epais(2)
+  !
+  IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
+     IF (jour.GT.(360-1).AND.jour.LE.367) THEN
+       jour=360-1
+       print *,'JE: jour changed to jour= ',jour
+     ELSE
+       PRINT*,'Le jour demande n est pas correcte:', jour
+       CALL ABORT
+     ENDIF
+  ENDIF
+  !
+  ierr = NF_OPEN ("limitcarbon.nc", NF_NOWRITE, nid1)
+  if (ierr.ne.NF_NOERR) then
+    write(6,*)' Pb d''ouverture du fichier limitbc.nc'
+    write(6,*)' ierr = ', ierr
+    call exit(1)
+  endif
+  !
+  ! Tranche a lire:
+  debut(1) = 1
+  debut(2) = jour+1
+  epais(1) = klon
+  epais(2) = 1
+  !
+  !
+  ierr = NF_INQ_VARID (nid1, "BCFF", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcff)
+   ! print *,'IERR = ',ierr
+   ! print *,'NF_NOERR = ',NF_NOERR
+   ! print *,'debut = ',debut
+   ! print *,'epais = ',epais
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcff)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC'
+     CALL exit(1)
+  ENDIF
+  !
+  !
+  ierr = NF_INQ_VARID (nid1, "BCBB", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcbb)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcbb)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC-biomass'
+     CALL exit(1)
+  ENDIF
+  !
+  !
+  ierr = NF_INQ_VARID (nid1, "BCBL", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcbbl)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcbbl)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC low'
+     CALL exit(1)
+  ENDIF
+  !
+  !
+  ierr = NF_INQ_VARID (nid1, "BCBH", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_bcbbh)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_bcbbh)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC high'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid1, "TERP", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_terp)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_terp)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources Terpene'
+     CALL exit(1)
+  ENDIF
+  !
+  !
+  ierr = NF_INQ_VARID (nid1, "BC_penner", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, &
+        epais, lmt_bc_penner)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais,
+  !nhl      .       lmt_bc_penner)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC Penner'
+     CALL exit(1)
+  ENDIF
+  !
+  !
+  ierr = NF_INQ_VARID (nid1, "OMFF", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, lmt_omff)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid1, nvarid, debut, epais, lmt_omff)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources om-ifossil'
+     CALL exit(1)
+  ENDIF
+  !
+  DO i=1,klon
+    lmt_ombb(i)  = lmt_bcbb(i)*7.0*1.6      !OC/BC=7.0;OM/OC=1.6
+    lmt_ombbl(i) = lmt_bcbbl(i)*7.0*1.6
+    lmt_ombbh(i) = lmt_bcbbh(i)*7.0*1.6
+    lmt_omff(i)  = lmt_omff(i)*1.4          !--OM/OC=1.4
+    lmt_omnat(i)  = lmt_terp(i)*0.11*1.4 !-- 11% Terpene is OC
+  ENDDO
+  !
+  ierr = NF_CLOSE(nid1)
+  PRINT*, 'Carbon sources lues pour jour: ', jour
+  !
+  RETURN
+END SUBROUTINE condsurfc

LMDZ6/trunk/libf/phylmd/Dust/condsurfc_new.f90

-                      r5245
+                      r5246
+      SUBROUTINE condsurfc_new(jour,lmt_bcff, lmt_bcnff,
      .                         lmt_bcbbl,lmt_bcbbh, lmt_bcba,
      .                         lmt_omff,lmt_omnff,lmt_ombbl,lmt_ombbh,
      .                                             lmt_omnat, lmt_omba)
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
       USE dimphy
       IMPLICIT none
+c
 c Lire les conditions aux limites du modele pour la chimie.
 c --------------------------------------------------------
+c
       INCLUDE "dimensions.h"
       INCLUDE "netcdf.inc"
       REAL lmt_bcff(klon), lmt_bcnff(klon), lmt_bcba(klon)
       REAL lmt_omff(klon), lmt_omnff(klon), lmt_ombb(klon)
       REAL lmt_bcbbl(klon), lmt_bcbbh(klon)
       REAL lmt_ombbl(klon), lmt_ombbh(klon)
       REAL lmt_omnat(klon), lmt_omba(klon)
       REAL lmt_terp(klon)
+c
       REAL lmt_bcff_glo(klon_glo), lmt_bcnff_glo(klon_glo)
       REAL lmt_bcba_glo(klon_glo)
       REAL lmt_omff_glo(klon_glo), lmt_omnff_glo(klon_glo)
       REAL lmt_ombb_glo(klon_glo)
       REAL lmt_bcbbl_glo(klon_glo), lmt_bcbbh_glo(klon_glo)
       REAL lmt_ombbl_glo(klon_glo), lmt_ombbh_glo(klon_glo)
       REAL lmt_omnat_glo(klon_glo), lmt_omba_glo(klon_glo)
       REAL lmt_terp_glo(klon_glo)
+!
       INTEGER jour, i
       INTEGER ierr
       INTEGER nid1,nvarid
       INTEGER debut(2),epais(2)
+c
 !      IF (jour.LT.0 .OR. jour.GT.(366-1)) THEN
       IF (jour.LT.0 .OR. jour.GT.366) THEN
          PRINT*,'Le jour demande n est pas correcte:', jour
          print *,'JE: FORCED TO CONTINUE (emissions have
      . to be longer than 1 year!!!! )'
 !JE         CALL ABORT
       ENDIF
+SUBROUTINE condsurfc_new(jour,lmt_bcff, lmt_bcnff, &
+        lmt_bcbbl,lmt_bcbbh, lmt_bcba, &
+        lmt_omff,lmt_omnff,lmt_ombbl,lmt_ombbh, &
+        lmt_omnat, lmt_omba)
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE dimphy
+  IMPLICIT none
+  !
+  ! Lire les conditions aux limites du modele pour la chimie.
+  ! --------------------------------------------------------
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "netcdf.inc"
+  REAL :: lmt_bcff(klon), lmt_bcnff(klon), lmt_bcba(klon)
+  REAL :: lmt_omff(klon), lmt_omnff(klon), lmt_ombb(klon)
+  REAL :: lmt_bcbbl(klon), lmt_bcbbh(klon)
+  REAL :: lmt_ombbl(klon), lmt_ombbh(klon)
+  REAL :: lmt_omnat(klon), lmt_omba(klon)
+  REAL :: lmt_terp(klon)
+  !
+  REAL :: lmt_bcff_glo(klon_glo), lmt_bcnff_glo(klon_glo)
+  REAL :: lmt_bcba_glo(klon_glo)
+  REAL :: lmt_omff_glo(klon_glo), lmt_omnff_glo(klon_glo)
+  REAL :: lmt_ombb_glo(klon_glo)
+  REAL :: lmt_bcbbl_glo(klon_glo), lmt_bcbbh_glo(klon_glo)
+  REAL :: lmt_ombbl_glo(klon_glo), lmt_ombbh_glo(klon_glo)
+  REAL :: lmt_omnat_glo(klon_glo), lmt_omba_glo(klon_glo)
+  REAL :: lmt_terp_glo(klon_glo)
+  !
+  INTEGER :: jour, i
+  INTEGER :: ierr
+  INTEGER :: nid1,nvarid
+  INTEGER :: debut(2),epais(2)
+  !
+  !  IF (jour.LT.0 .OR. jour.GT.(366-1)) THEN
+  IF (jour.LT.0 .OR. jour.GT.366) THEN
+     PRINT*,'Le jour demande n est pas correcte:', jour
+     print *,'JE: FORCED TO CONTINUE (emissions have&
+           & to be longer than 1 year!!!! )'
+  !JE         CALL ABORT
+  ENDIF
 !$OMP MASTER
       IF (is_mpi_root .AND. is_omp_root) THEN
+!
 ! Tranche a lire:
       debut(1) = 1
       debut(2) = jour
       epais(1) = klon_glo
 !      epais(1) = klon
       epais(2) = 1
+!
 !=======================================================================
 !                        BC EMISSIONS
 !=======================================================================
+!
       ierr = NF_OPEN ("carbon_emissions.nc", NF_NOWRITE, nid1)
       if (ierr.ne.NF_NOERR) then
         write(6,*)' Pb d''ouverture du fichier limitbc.nc'
         write(6,*)' ierr = ', ierr
         call exit(1)
       endif
+!
 ! BC emissions from fossil fuel combustion
+!
       ierr = NF_INQ_VARID (nid1, "BCFF", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .  lmt_bcff_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC'
          CALL exit(1)
       ENDIF
       !print *,'lmt_bcff = ',lmt_bcff
       !stop
+!
 ! BC emissions from non fossil fuel combustion
+!
       ierr = NF_INQ_VARID (nid1, "BCNFF", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .    lmt_bcnff_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC'
          CALL exit(1)
       ENDIF
+!
 ! Low BC emissions from biomass burning
+!
       ierr = NF_INQ_VARID (nid1, "BCBBL", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .  lmt_bcbbl_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC low'
          CALL exit(1)
       ENDIF
+!
 ! High BC emissions from biomass burning
+!
       ierr = NF_INQ_VARID (nid1, "BCBBH", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .      lmt_bcbbh_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC high'
          CALL exit(1)
       ENDIF
+!
 ! BC emissions from ship transport
+!
       ierr = NF_INQ_VARID (nid1, "BCBA", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .   lmt_bcba_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources BC'
          CALL exit(1)
       ENDIF
+!
 !=======================================================================
+!                        OM EMISSIONS
 !=======================================================================
+!
+!
 ! OM emissions from fossil fuel combustion
+!
       ierr = NF_INQ_VARID (nid1, "OMFF", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .  lmt_omff_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources OM'
          CALL exit(1)
       ENDIF
+!
 ! OM emissions from non fossil fuel combustion
+!
       ierr = NF_INQ_VARID (nid1, "OMNFF", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .   lmt_omnff_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources OM'
          CALL exit(1)
       ENDIF
+!
 ! Low OM emissions from biomass burning - low
+!
       ierr = NF_INQ_VARID (nid1, "OMBBL", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .  lmt_ombbl_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources OM low'
          CALL exit(1)
       ENDIF
+!
 ! High OM emissions from biomass burning - high
+!
       ierr = NF_INQ_VARID (nid1, "OMBBH", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .  lmt_ombbh_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources OM high'
          CALL exit(1)
       ENDIF
+!
 ! High OM emissions from ship
+!
       ierr = NF_INQ_VARID (nid1, "OMBA", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .   lmt_omba_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources OM ship'
          CALL exit(1)
       ENDIF
+!
 ! Natural Terpene emissions => Natural OM emissions
+!
       ierr = NF_INQ_VARID (nid1, "TERP", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais,
      .  lmt_terp_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources Terpene'
          CALL exit(1)
       ENDIF
+!
       DO i=1,klon_glo
         lmt_omnat_glo(i)  = lmt_terp_glo(i)*0.11*1.4 !-- 11% Terpene is OC
       ENDDO
       ierr = NF_CLOSE(nid1)
+!
       PRINT*, 'Carbon sources lues pour jour: ', jour
 !      lmt_bcff(klon)=0.0
 !      lmt_bcnff(klon)=0.0
 !      lmt_omff(klon)=0.0
 !      lmt_omnff(klon)=0.0
 !      lmt_ombb(klon)=0.0
 !      lmt_bcbbl(klon)=0.0
 !      lmt_bcbbh(klon)=0.0
 !      lmt_ombbl(klon)=0.0
 !      lmt_ombbh(klon)=0.0
 !      lmt_omnat(klon)=0.0
 !      lmt_omba(klon)=0.0
 !      lmt_terp(klon)=0.0
       ENDIF
+  IF (is_mpi_root .AND. is_omp_root) THEN
+  !
+  ! Tranche a lire:
+  debut(1) = 1
+  debut(2) = jour
+  epais(1) = klon_glo
+   ! epais(1) = klon
+  epais(2) = 1
+  !
+  !=======================================================================
+  !                    BC EMISSIONS
+  !=======================================================================
+  !
+  ierr = NF_OPEN ("carbon_emissions.nc", NF_NOWRITE, nid1)
+  if (ierr.ne.NF_NOERR) then
+    write(6,*)' Pb d''ouverture du fichier limitbc.nc'
+    write(6,*)' ierr = ', ierr
+    call exit(1)
+  endif
+  !
+  ! BC emissions from fossil fuel combustion
+  !
+  ierr = NF_INQ_VARID (nid1, "BCFF", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_bcff_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC'
+     CALL exit(1)
+  ENDIF
+  ! !print *,'lmt_bcff = ',lmt_bcff
+  ! !stop
+  !
+  ! BC emissions from non fossil fuel combustion
+  !
+  ierr = NF_INQ_VARID (nid1, "BCNFF", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_bcnff_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC'
+     CALL exit(1)
+  ENDIF
+  !
+  ! Low BC emissions from biomass burning
+  !
+  ierr = NF_INQ_VARID (nid1, "BCBBL", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_bcbbl_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC low'
+     CALL exit(1)
+  ENDIF
+  !
+  ! High BC emissions from biomass burning
+  !
+  ierr = NF_INQ_VARID (nid1, "BCBBH", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_bcbbh_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC high'
+     CALL exit(1)
+  ENDIF
+  !
+  ! BC emissions from ship transport
+  !
+  ierr = NF_INQ_VARID (nid1, "BCBA", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_bcba_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources BC'
+     CALL exit(1)
+  ENDIF
+  !
+  !=======================================================================
+                     ! OM EMISSIONS
+  !=======================================================================
+  !
+  !
+  ! OM emissions from fossil fuel combustion
+  !
+  ierr = NF_INQ_VARID (nid1, "OMFF", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_omff_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources OM'
+     CALL exit(1)
+  ENDIF
+  !
+  ! OM emissions from non fossil fuel combustion
+  !
+  ierr = NF_INQ_VARID (nid1, "OMNFF", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_omnff_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources OM'
+     CALL exit(1)
+  ENDIF
+  !
+  ! Low OM emissions from biomass burning - low
+  !
+  ierr = NF_INQ_VARID (nid1, "OMBBL", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_ombbl_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources OM low'
+     CALL exit(1)
+  ENDIF
+  !
+  ! High OM emissions from biomass burning - high
+  !
+  ierr = NF_INQ_VARID (nid1, "OMBBH", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_ombbh_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources OM high'
+     CALL exit(1)
+  ENDIF
+  !
+  ! High OM emissions from ship
+  !
+  ierr = NF_INQ_VARID (nid1, "OMBA", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_omba_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources OM ship'
+     CALL exit(1)
+  ENDIF
+  !
+  ! Natural Terpene emissions => Natural OM emissions
+  !
+  ierr = NF_INQ_VARID (nid1, "TERP", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid1, nvarid, debut, epais, &
+        lmt_terp_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources Terpene'
+     CALL exit(1)
+  ENDIF
+  !
+  DO i=1,klon_glo
+    lmt_omnat_glo(i)  = lmt_terp_glo(i)*0.11*1.4 !-- 11% Terpene is OC
+  ENDDO
+  ierr = NF_CLOSE(nid1)
+  !
+  PRINT*, 'Carbon sources lues pour jour: ', jour
+   ! lmt_bcff(klon)=0.0
+   ! lmt_bcnff(klon)=0.0
+   ! lmt_omff(klon)=0.0
+   ! lmt_omnff(klon)=0.0
+   ! lmt_ombb(klon)=0.0
+   ! lmt_bcbbl(klon)=0.0
+   ! lmt_bcbbh(klon)=0.0
+   ! lmt_ombbl(klon)=0.0
+   ! lmt_ombbh(klon)=0.0
+   ! lmt_omnat(klon)=0.0
+   ! lmt_omba(klon)=0.0
+   ! lmt_terp(klon)=0.0
+  ENDIF
 !$OMP END MASTER
 !$OMP BARRIER
       call scatter( lmt_bcff_glo   , lmt_bcff )
       call scatter( lmt_bcnff_glo  , lmt_bcnff )
       call scatter( lmt_bcbbl_glo  , lmt_bcbbl )
       call scatter( lmt_bcbbh_glo  , lmt_bcbbh )
       call scatter( lmt_bcba_glo   , lmt_bcba )
       call scatter( lmt_omff_glo   , lmt_omff )
       call scatter( lmt_omnff_glo  , lmt_omnff )
       call scatter( lmt_ombbl_glo  , lmt_ombbl )
       call scatter( lmt_ombbh_glo  , lmt_ombbh )
       call scatter( lmt_omba_glo   , lmt_omba )
       call scatter( lmt_terp_glo   , lmt_terp )
       call scatter( lmt_omnat_glo  , lmt_omnat )
       RETURN
+      END
+  call scatter( lmt_bcff_glo   , lmt_bcff )
+  call scatter( lmt_bcnff_glo  , lmt_bcnff )
+  call scatter( lmt_bcbbl_glo  , lmt_bcbbl )
+  call scatter( lmt_bcbbh_glo  , lmt_bcbbh )
+  call scatter( lmt_bcba_glo   , lmt_bcba )
+  call scatter( lmt_omff_glo   , lmt_omff )
+  call scatter( lmt_omnff_glo  , lmt_omnff )
+  call scatter( lmt_ombbl_glo  , lmt_ombbl )
+  call scatter( lmt_ombbh_glo  , lmt_ombbh )
+  call scatter( lmt_omba_glo   , lmt_omba )
+  call scatter( lmt_terp_glo   , lmt_terp )
+  call scatter( lmt_omnat_glo  , lmt_omnat )
+  RETURN
+END SUBROUTINE condsurfc_new

LMDZ6/trunk/libf/phylmd/Dust/condsurfs.f90

-                      r5245
+                      r5246
+      SUBROUTINE condsurfs(jour, edgar, flag_dms,
      .                     lmt_so2h, lmt_so2b, lmt_so2bb, lmt_so2ba,
      .                     lmt_so2volc, lmt_altvolc,
      .                     lmt_dmsbio, lmt_h2sbio, lmt_dms, lmt_dmsconc)
        USE dimphy
       IMPLICIT none
+c
 c Lire les conditions aux limites du modele pour la chimie.
 c --------------------------------------------------------
+c
       INCLUDE "dimensions.h"
       INCLUDE "netcdf.inc"
+c
       REAL lmt_so2h(klon), lmt_so2b(klon), lmt_so2bb(klon)
       REAL lmt_dmsbio(klon), lmt_h2sbio(klon), lmt_so2ba(klon)
       REAL lmt_so2volc(klon), lmt_altvolc(klon)
       REAL lmt_dms(klon), lmt_dmsconc(klon)
       LOGICAL edgar
       INTEGER flag_dms
+c
       INTEGER jour, i
       INTEGER ierr
       INTEGER nid,nvarid
       INTEGER debut(2),epais(2)
+c
       IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
          IF ((jour.GT.(360-1)) .AND. (jour.LE.367)) THEN
            jour=360-1
            print *,'JE: jour changed to jour= ',jour
          ELSE
            PRINT*,'Le jour demande n est pas correcte:', jour
            CALL ABORT
          ENDIF
       ENDIF
+c
       ierr = NF_OPEN ("limitsoufre.nc", NF_NOWRITE, nid)
       if (ierr.ne.NF_NOERR) then
         write(6,*)' Pb d''ouverture du fichier limitsoufre.nc'
         write(6,*)' ierr = ', ierr
         call exit(1)
       endif
+c
 c Tranche a lire:
       debut(1) = 1
       debut(2) = jour+1
       epais(1) = klon
       epais(2) = 1
+c
       ierr = NF_INQ_VARID (nid, "VOLC", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2volc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2volc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 volcan'
          CALL exit(1)
       ENDIF
+c
       ierr = NF_INQ_VARID (nid, "ALTI", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_altvolc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_altvolc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les altitudes volcan'
          CALL exit(1)
       ENDIF
+c
       IF (edgar) THEN   !--EDGAR w/o ship and biomass burning
+c
       ierr = NF_INQ_VARID (nid, "SO2ED95L", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2b)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2b)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 edgar low'
          CALL exit(1)
       ENDIF
+c
       ierr = NF_INQ_VARID (nid, "SO2ED95H", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2h)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2h)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 edgar high'
          CALL exit(1)
       ENDIF
+c
       ELSE  !--GEIA
+c
       ierr = NF_INQ_VARID (nid, "SO2H", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2h)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2h)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 haut'
          CALL exit(1)
       ENDIF
+c
       ierr = NF_INQ_VARID (nid, "SO2B", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2b)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2b)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 bas'
          CALL exit(1)
       ENDIF
+c
       ENDIF  !--edgar
+c
       ierr = NF_INQ_VARID (nid, "SO2BB", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2bb)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2bb)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 bb'
          CALL exit(1)
       ENDIF
+c
       ierr = NF_INQ_VARID (nid, "SO2BA", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2ba)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2ba)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 bateau'
          CALL exit(1)
       ENDIF
+c
       ierr = NF_INQ_VARID (nid, "DMSB", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_dmsbio)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsbio)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms bio'
          CALL exit(1)
       ENDIF
+c
       ierr = NF_INQ_VARID (nid, "H2SB", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_h2sbio)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_h2sbio)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources h2s bio'
          CALL exit(1)
       ENDIF
+c
       IF (flag_dms.EQ.1) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSL", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_dms)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dms)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms liss'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.2) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSW", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_dms)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dms)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms wann'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.3) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC1", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dmsconc old'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.4) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC2", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 2'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.5) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC3", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 3'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.6) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC4", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 4'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.7) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC5", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 5'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.8) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC6", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 6'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.9) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC7", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 7'
          CALL exit(1)
       ENDIF
+c
       ELSEIF (flag_dms.EQ.10) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC8", nvarid)
 cnhl #ifdef NC_DOUBLE
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
 cnhl #else
 cnhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
 cnhl #endif
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 8'
          CALL exit(1)
       ENDIF
+c
       ELSE
+c
          PRINT *,'choix non possible pour flag_dms'
          STOP
+c
       ENDIF
+c
       ierr = NF_CLOSE(nid)
+c
       IF (flag_dms.LE.2) THEN
       DO i=1, klon
          lmt_dmsconc(i)=0.0
       ENDDO
       ELSE
       DO i=1, klon
          lmt_dms(i)=0.0
       ENDDO
       ENDIF
+c
       PRINT*, 'Sources SOUFRE lues pour jour: ', jour
+c
       RETURN
+      END
+SUBROUTINE condsurfs(jour, edgar, flag_dms, &
+        lmt_so2h, lmt_so2b, lmt_so2bb, lmt_so2ba, &
+        lmt_so2volc, lmt_altvolc, &
+        lmt_dmsbio, lmt_h2sbio, lmt_dms, lmt_dmsconc)
+   USE dimphy
+  IMPLICIT none
+  !
+  ! Lire les conditions aux limites du modele pour la chimie.
+  ! --------------------------------------------------------
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "netcdf.inc"
+  !
+  REAL :: lmt_so2h(klon), lmt_so2b(klon), lmt_so2bb(klon)
+  REAL :: lmt_dmsbio(klon), lmt_h2sbio(klon), lmt_so2ba(klon)
+  REAL :: lmt_so2volc(klon), lmt_altvolc(klon)
+  REAL :: lmt_dms(klon), lmt_dmsconc(klon)
+  LOGICAL :: edgar
+  INTEGER :: flag_dms
+  !
+  INTEGER :: jour, i
+  INTEGER :: ierr
+  INTEGER :: nid,nvarid
+  INTEGER :: debut(2),epais(2)
+  !
+  IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
+     IF ((jour.GT.(360-1)) .AND. (jour.LE.367)) THEN
+       jour=360-1
+       print *,'JE: jour changed to jour= ',jour
+     ELSE
+       PRINT*,'Le jour demande n est pas correcte:', jour
+       CALL ABORT
+     ENDIF
+  ENDIF
+  !
+  ierr = NF_OPEN ("limitsoufre.nc", NF_NOWRITE, nid)
+  if (ierr.ne.NF_NOERR) then
+    write(6,*)' Pb d''ouverture du fichier limitsoufre.nc'
+    write(6,*)' ierr = ', ierr
+    call exit(1)
+  endif
+  !
+  ! Tranche a lire:
+  debut(1) = 1
+  debut(2) = jour+1
+  epais(1) = klon
+  epais(2) = 1
+  !
+  ierr = NF_INQ_VARID (nid, "VOLC", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2volc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2volc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 volcan'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid, "ALTI", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_altvolc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_altvolc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les altitudes volcan'
+     CALL exit(1)
+  ENDIF
+  !
+  IF (edgar) THEN   !--EDGAR w/o ship and biomass burning
+  !
+  ierr = NF_INQ_VARID (nid, "SO2ED95L", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2b)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2b)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 edgar low'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid, "SO2ED95H", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2h)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2h)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 edgar high'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSE  !--GEIA
+  !
+  ierr = NF_INQ_VARID (nid, "SO2H", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2h)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2h)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 haut'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid, "SO2B", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2b)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2b)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 bas'
+     CALL exit(1)
+  ENDIF
+  !
+  ENDIF  !--edgar
+  !
+  ierr = NF_INQ_VARID (nid, "SO2BB", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2bb)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2bb)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 bb'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid, "SO2BA", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_so2ba)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_so2ba)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 bateau'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid, "DMSB", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_dmsbio)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsbio)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms bio'
+     CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_INQ_VARID (nid, "H2SB", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_h2sbio)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_h2sbio)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources h2s bio'
+     CALL exit(1)
+  ENDIF
+  !
+  IF (flag_dms.EQ.1) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSL", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_dms)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dms)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms liss'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.2) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSW", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, lmt_dms)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dms)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms wann'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.3) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC1", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dmsconc old'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.4) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC2", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 2'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.5) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC3", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 3'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.6) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC4", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 4'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.7) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC5", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 5'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.8) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC6", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 6'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.9) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC7", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 7'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSEIF (flag_dms.EQ.10) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC8", nvarid)
+  !nhl #ifdef NC_DOUBLE
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_dmsconc)
+  !nhl #else
+  !nhl       ierr = NF_GET_VARA_REAL (nid, nvarid, debut, epais, lmt_dmsconc)
+  !nhl #endif
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 8'
+     CALL exit(1)
+  ENDIF
+  !
+  ELSE
+  !
+     PRINT *,'choix non possible pour flag_dms'
+     STOP
+  !
+  ENDIF
+  !
+  ierr = NF_CLOSE(nid)
+  !
+  IF (flag_dms.LE.2) THEN
+  DO i=1, klon
+     lmt_dmsconc(i)=0.0
+  ENDDO
+  ELSE
+  DO i=1, klon
+     lmt_dms(i)=0.0
+  ENDDO
+  ENDIF
+  !
+  PRINT*, 'Sources SOUFRE lues pour jour: ', jour
+  !
+  RETURN
+END SUBROUTINE condsurfs

LMDZ6/trunk/libf/phylmd/Dust/condsurfs_new.f90

-                      r5245
+                      r5246
+      SUBROUTINE condsurfs_new(jour, edgar, flag_dms,
      .                         lmt_so2b, lmt_so2h, lmt_so2nff,
      .                         lmt_so2bb_l, lmt_so2bb_h, lmt_so2ba,
      .                         lmt_so2volc_cont, lmt_altvolc_cont,
      .                         lmt_so2volc_expl, lmt_altvolc_expl,
      .                         lmt_dmsbio, lmt_h2sbio, lmt_dms,
      .                                                      lmt_dmsconc)
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
       USE dimphy
       IMPLICIT none
+c
 c Lire les conditions aux limites du modele pour la chimie.
 c --------------------------------------------------------
+c
       INCLUDE "dimensions.h"
       INCLUDE "netcdf.inc"
+c
       REAL lmt_so2b(klon), lmt_so2h(klon), lmt_so2nff(klon)
       REAL lmt_so2bb_l(klon), lmt_so2bb_h(klon)
       REAL lmt_dmsbio(klon), lmt_h2sbio(klon), lmt_so2ba(klon)
       REAL lmt_so2volc_cont(klon), lmt_altvolc_cont(klon)
       REAL lmt_so2volc_expl(klon), lmt_altvolc_expl(klon)
       REAL lmt_dms(klon), lmt_dmsconc(klon)
       REAL lmt_so2b_glo(klon_glo), lmt_so2h_glo(klon_glo)
       REAL lmt_so2nff_glo(klon_glo)
       REAL lmt_so2bb_l_glo(klon_glo), lmt_so2bb_h_glo(klon_glo)
       REAL lmt_dmsbio_glo(klon_glo), lmt_h2sbio_glo(klon_glo)
       REAL lmt_so2ba_glo(klon_glo)
       REAL lmt_so2volc_cont_glo(klon_glo),lmt_altvolc_cont_glo(klon_glo)
       REAL lmt_so2volc_expl_glo(klon_glo),lmt_altvolc_expl_glo(klon_glo)
       REAL lmt_dms_glo(klon_glo), lmt_dmsconc_glo(klon_glo)
       LOGICAL edgar
       INTEGER flag_dms
+c
       INTEGER jour, i
       INTEGER ierr
       INTEGER nid,nvarid
       INTEGER debut(2),epais(2)
+c
       IF (jour.LT.0 .OR. jour.GT.(366-1)) THEN
          PRINT*,'Le jour demande n est pas correcte:', jour
          print *,'JE: FORCED TO CONTINUE (emissions have
      . to be longer than 1 year!!!! )'
 !         CALL ABORT
       ENDIF
+!
+SUBROUTINE condsurfs_new(jour, edgar, flag_dms, &
+        lmt_so2b, lmt_so2h, lmt_so2nff, &
+        lmt_so2bb_l, lmt_so2bb_h, lmt_so2ba, &
+        lmt_so2volc_cont, lmt_altvolc_cont, &
+        lmt_so2volc_expl, lmt_altvolc_expl, &
+        lmt_dmsbio, lmt_h2sbio, lmt_dms, &
+        lmt_dmsconc)
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE dimphy
+  IMPLICIT none
+  !
+  ! Lire les conditions aux limites du modele pour la chimie.
+  ! --------------------------------------------------------
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "netcdf.inc"
+  !
+  REAL :: lmt_so2b(klon), lmt_so2h(klon), lmt_so2nff(klon)
+  REAL :: lmt_so2bb_l(klon), lmt_so2bb_h(klon)
+  REAL :: lmt_dmsbio(klon), lmt_h2sbio(klon), lmt_so2ba(klon)
+  REAL :: lmt_so2volc_cont(klon), lmt_altvolc_cont(klon)
+  REAL :: lmt_so2volc_expl(klon), lmt_altvolc_expl(klon)
+  REAL :: lmt_dms(klon), lmt_dmsconc(klon)
+  REAL :: lmt_so2b_glo(klon_glo), lmt_so2h_glo(klon_glo)
+  REAL :: lmt_so2nff_glo(klon_glo)
+  REAL :: lmt_so2bb_l_glo(klon_glo), lmt_so2bb_h_glo(klon_glo)
+  REAL :: lmt_dmsbio_glo(klon_glo), lmt_h2sbio_glo(klon_glo)
+  REAL :: lmt_so2ba_glo(klon_glo)
+  REAL :: lmt_so2volc_cont_glo(klon_glo),lmt_altvolc_cont_glo(klon_glo)
+  REAL :: lmt_so2volc_expl_glo(klon_glo),lmt_altvolc_expl_glo(klon_glo)
+  REAL :: lmt_dms_glo(klon_glo), lmt_dmsconc_glo(klon_glo)
+  LOGICAL :: edgar
+  INTEGER :: flag_dms
+  !
+  INTEGER :: jour, i
+  INTEGER :: ierr
+  INTEGER :: nid,nvarid
+  INTEGER :: debut(2),epais(2)
+  !
+  IF (jour.LT.0 .OR. jour.GT.(366-1)) THEN
+     PRINT*,'Le jour demande n est pas correcte:', jour
+     print *,'JE: FORCED TO CONTINUE (emissions have&
+           & to be longer than 1 year!!!! )'
+      ! CALL ABORT
+  ENDIF
+  !
 !$OMP MASTER
       IF (is_mpi_root .AND. is_omp_root) THEN
 c Tranche a lire:
       debut(1) = 1
       debut(2) = jour
 !      epais(1) = klon
       epais(1) = klon_glo
       epais(2) = 1
 !=======================================================================
 !                 READING NEW EMISSIONS FROM RCP
 !=======================================================================
+!
       ierr = NF_OPEN ("sulphur_emissions_antro.nc", NF_NOWRITE, nid)
       if (ierr.ne.NF_NOERR) then
         write(6,*)' Pb d''ouverture du fichier sulphur_emissions_antro'
         write(6,*)' ierr = ', ierr
         call exit(1)
       endif
+!
 ! SO2 Low level emissions
+!
       ierr = NF_INQ_VARID (nid, "SO2FF_LOW", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,lmt_so2b_glo)
       IF (ierr .NE. NF_NOERR) THEN
         PRINT*, 'Pb de lecture pour les sources so2 low'
         print *,'JE klon, jour, debut ,epais ',klon_glo,jour,debut,epais
         CALL HANDLE_ERR(ierr)
         print *,'error ierr= ',ierr
         CALL exit(1)
       ENDIF
+!
 ! SO2 High level emissions
+!
       ierr = NF_INQ_VARID (nid, "SO2FF_HIGH", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,lmt_so2h_glo)
       IF (ierr .NE. NF_NOERR) THEN
         PRINT*, 'Pb de lecture pour les sources so2 high'
         CALL exit(1)
       ENDIF
+!
 ! SO2 Biomass burning High level emissions
+!
       ierr = NF_INQ_VARID (nid, "SO2BBH", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,
      . epais, lmt_so2bb_h_glo)
       IF (ierr .NE. NF_NOERR) THEN
         PRINT*, 'Pb de lecture pour les sources so2 BB high'
         CALL exit(1)
       ENDIF
+!
 ! SO2 biomass burning low level emissions
+!
       ierr = NF_INQ_VARID (nid, "SO2BBL", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,
      . epais, lmt_so2bb_l_glo)
       IF (ierr .NE. NF_NOERR) THEN
         PRINT*, 'Pb de lecture pour les sources so2 BB low'
         CALL exit(1)
       ENDIF
+!
 ! SO2 ship emissions
+!
       ierr = NF_INQ_VARID (nid, "SO2BA", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_so2ba_glo)
       IF (ierr .NE. NF_NOERR) THEN
         PRINT*, 'Pb de lecture pour les sources so2 ship'
         CALL exit(1)
       ENDIF
+!
 ! SO2 Non Fossil Fuel Emissions
+!
       ierr = NF_INQ_VARID (nid, "SO2NFF", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,
      .  lmt_so2nff_glo)
       IF (ierr .NE. NF_NOERR) THEN
         PRINT*, 'Pb de lecture pour les sources so2 non FF'
         CALL exit(1)
       ENDIF
+!
       ierr = NF_CLOSE(nid)
+!
 !=======================================================================
 !                      READING NATURAL EMISSIONS
 !=======================================================================
       ierr = NF_OPEN ("sulphur_emissions_nat.nc", NF_NOWRITE, nid)
       if (ierr.ne.NF_NOERR) then
         write(6,*)' Pb d''ouverture du fichier sulphur_emissions_nat'
         write(6,*)' ierr = ', ierr
         call exit(1)
       endif
+c
 c Biologenic source of DMS
+c
       ierr = NF_INQ_VARID (nid, "DMSB", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid,debut,epais,lmt_dmsbio_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms bio'
          CALL exit(1)
       ENDIF
+c
 c Biologenic source of H2S
+c
       ierr = NF_INQ_VARID (nid, "H2SB", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid,debut,epais,lmt_h2sbio_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources h2s bio'
          CALL exit(1)
       ENDIF
+c
 c Ocean surface concentration of dms (emissions are computed later)
+c
       IF (flag_dms.EQ.4) THEN
+c
       ierr = NF_INQ_VARID (nid, "DMSC2", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid,nvarid,debut,epais,lmt_dmsconc_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources dms conc 2'
          CALL exit(1)
       ENDIF
+c
       DO i=1, klon
 !         lmt_dms(i)=0.0
          lmt_dms_glo(i)=0.0
       ENDDO
+c
       ELSE
+c
          PRINT *,'choix non possible pour flag_dms'
          STOP
       ENDIF
+c
       ierr = NF_CLOSE(nid)
+c
 !=======================================================================
 !                      READING VOLCANIC EMISSIONS
 !=======================================================================
       print *,'   ***      READING VOLCANIC EMISSIONS   ***   '
       print *,' Jour = ',jour
       ierr = NF_OPEN ("sulphur_emissions_volc.nc", NF_NOWRITE, nid)
       if (ierr.ne.NF_NOERR) then
         write(6,*)' Pb d''ouverture du fichier sulphur_emissions_volc'
         write(6,*)' ierr = ', ierr
         call exit(1)
       endif
+c
 c Continuous Volcanic emissions
+c
 !      ierr = NF_INQ_VARID (nid, "VOLC", nvarid)
       ierr = NF_INQ_VARID (nid, "flx_volc_cont", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,
      .                           lmt_so2volc_cont_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 volcan (cont)'
          CALL exit(1)
       ENDIF
       print *,'SO2 volc cont (in read) = ',SUM(lmt_so2volc_cont_glo),
      +      MINVAL(lmt_so2volc_cont_glo),MAXVAL(lmt_so2volc_cont_glo)
 !      lmt_so2volc(:)=0.0
+c
 c Altitud of continuous volcanic emissions
+c
 !      ierr = NF_INQ_VARID (nid, "ALTI", nvarid)
       ierr = NF_INQ_VARID (nid, "flx_volc_altcont", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,
      .                           lmt_altvolc_cont_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les altitudes volcan (cont)'
          CALL exit(1)
       ENDIF
+c
 c Explosive Volcanic emissions
+c
       ierr = NF_INQ_VARID (nid, "flx_volc_expl", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,
      .                           lmt_so2volc_expl_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les sources so2 volcan (expl)'
          CALL exit(1)
       ENDIF
 !      lmt_so2volc_expl(:)=0.0
       print *,'SO2 volc expl (in read) = ',SUM(lmt_so2volc_expl_glo),
      +      MINVAL(lmt_so2volc_expl_glo),MAXVAL(lmt_so2volc_expl_glo)
+c
 c Altitud of explosive volcanic emissions
+c
       ierr = NF_INQ_VARID (nid, "flx_volc_altexpl", nvarid)
       ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,
      .                           lmt_altvolc_expl_glo)
       IF (ierr .NE. NF_NOERR) THEN
          PRINT*, 'Pb de lecture pour les altitudes volcan'
          CALL exit(1)
       ENDIF
 !      lmt_altvolc_expl(:)=0.0
       ierr = NF_CLOSE(nid)
+c
       PRINT*, 'Sources SOUFRE lues pour jour: ', jour
+c
       ENDIF
+  IF (is_mpi_root .AND. is_omp_root) THEN
+  ! Tranche a lire:
+  debut(1) = 1
+  debut(2) = jour
+   ! epais(1) = klon
+  epais(1) = klon_glo
+  epais(2) = 1
+  !=======================================================================
+              ! READING NEW EMISSIONS FROM RCP
+  !=======================================================================
+  !
+  ierr = NF_OPEN ("sulphur_emissions_antro.nc", NF_NOWRITE, nid)
+  if (ierr.ne.NF_NOERR) then
+    write(6,*)' Pb d''ouverture du fichier sulphur_emissions_antro'
+    write(6,*)' ierr = ', ierr
+    call exit(1)
+  endif
+  !
+  ! SO2 Low level emissions
+  !
+  ierr = NF_INQ_VARID (nid, "SO2FF_LOW", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,lmt_so2b_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+    PRINT*, 'Pb de lecture pour les sources so2 low'
+    print *,'JE klon, jour, debut ,epais ',klon_glo,jour,debut,epais
+    CALL HANDLE_ERR(ierr)
+    print *,'error ierr= ',ierr
+    CALL exit(1)
+  ENDIF
+  !
+  ! SO2 High level emissions
+  !
+  ierr = NF_INQ_VARID (nid, "SO2FF_HIGH", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais,lmt_so2h_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+    PRINT*, 'Pb de lecture pour les sources so2 high'
+    CALL exit(1)
+  ENDIF
+  !
+  ! SO2 Biomass burning High level emissions
+  !
+  ierr = NF_INQ_VARID (nid, "SO2BBH", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, &
+        epais, lmt_so2bb_h_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+    PRINT*, 'Pb de lecture pour les sources so2 BB high'
+    CALL exit(1)
+  ENDIF
+  !
+  ! SO2 biomass burning low level emissions
+  !
+  ierr = NF_INQ_VARID (nid, "SO2BBL", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, &
+        epais, lmt_so2bb_l_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+    PRINT*, 'Pb de lecture pour les sources so2 BB low'
+    CALL exit(1)
+  ENDIF
+  !
+  ! SO2 ship emissions
+  !
+  ierr = NF_INQ_VARID (nid, "SO2BA", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut,epais,lmt_so2ba_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+    PRINT*, 'Pb de lecture pour les sources so2 ship'
+    CALL exit(1)
+  ENDIF
+  !
+  ! SO2 Non Fossil Fuel Emissions
+  !
+  ierr = NF_INQ_VARID (nid, "SO2NFF", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, &
+        lmt_so2nff_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+    PRINT*, 'Pb de lecture pour les sources so2 non FF'
+    CALL exit(1)
+  ENDIF
+  !
+  ierr = NF_CLOSE(nid)
+  !
+  !=======================================================================
+                   ! READING NATURAL EMISSIONS
+  !=======================================================================
+  ierr = NF_OPEN ("sulphur_emissions_nat.nc", NF_NOWRITE, nid)
+  if (ierr.ne.NF_NOERR) then
+    write(6,*)' Pb d''ouverture du fichier sulphur_emissions_nat'
+    write(6,*)' ierr = ', ierr
+    call exit(1)
+  endif
+  !
+  ! Biologenic source of DMS
+  !
+  ierr = NF_INQ_VARID (nid, "DMSB", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid,debut,epais,lmt_dmsbio_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms bio'
+     CALL exit(1)
+  ENDIF
+  !
+  ! Biologenic source of H2S
+  !
+  ierr = NF_INQ_VARID (nid, "H2SB", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid,debut,epais,lmt_h2sbio_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources h2s bio'
+     CALL exit(1)
+  ENDIF
+  !
+  ! Ocean surface concentration of dms (emissions are computed later)
+  !
+  IF (flag_dms.EQ.4) THEN
+  !
+  ierr = NF_INQ_VARID (nid, "DMSC2", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid,nvarid,debut,epais,lmt_dmsconc_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources dms conc 2'
+     CALL exit(1)
+  ENDIF
+  !
+  DO i=1, klon
+      ! lmt_dms(i)=0.0
+     lmt_dms_glo(i)=0.0
+  ENDDO
+  !
+  ELSE
+  !
+     PRINT *,'choix non possible pour flag_dms'
+     STOP
+  ENDIF
+  !
+  ierr = NF_CLOSE(nid)
+  !
+  !=======================================================================
+  !                  READING VOLCANIC EMISSIONS
+  !=======================================================================
+  print *,'   ***      READING VOLCANIC EMISSIONS   ***   '
+  print *,' Jour = ',jour
+  ierr = NF_OPEN ("sulphur_emissions_volc.nc", NF_NOWRITE, nid)
+  if (ierr.ne.NF_NOERR) then
+    write(6,*)' Pb d''ouverture du fichier sulphur_emissions_volc'
+    write(6,*)' ierr = ', ierr
+    call exit(1)
+  endif
+  !
+  ! Continuous Volcanic emissions
+  !
+  !  ierr = NF_INQ_VARID (nid, "VOLC", nvarid)
+  ierr = NF_INQ_VARID (nid, "flx_volc_cont", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, &
+        lmt_so2volc_cont_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 volcan (cont)'
+     CALL exit(1)
+  ENDIF
+  print *,'SO2 volc cont (in read) = ',SUM(lmt_so2volc_cont_glo), &
+        MINVAL(lmt_so2volc_cont_glo),MAXVAL(lmt_so2volc_cont_glo)
+   ! lmt_so2volc(:)=0.0
+  !
+  ! Altitud of continuous volcanic emissions
+  !
+  !  ierr = NF_INQ_VARID (nid, "ALTI", nvarid)
+  ierr = NF_INQ_VARID (nid, "flx_volc_altcont", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, &
+        lmt_altvolc_cont_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les altitudes volcan (cont)'
+     CALL exit(1)
+  ENDIF
+  !
+  ! Explosive Volcanic emissions
+  !
+  ierr = NF_INQ_VARID (nid, "flx_volc_expl", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, &
+        lmt_so2volc_expl_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les sources so2 volcan (expl)'
+     CALL exit(1)
+  ENDIF
+   ! lmt_so2volc_expl(:)=0.0
+  print *,'SO2 volc expl (in read) = ',SUM(lmt_so2volc_expl_glo), &
+        MINVAL(lmt_so2volc_expl_glo),MAXVAL(lmt_so2volc_expl_glo)
+  !
+  ! Altitud of explosive volcanic emissions
+  !
+  ierr = NF_INQ_VARID (nid, "flx_volc_altexpl", nvarid)
+  ierr = NF_GET_VARA_DOUBLE (nid, nvarid, debut, epais, &
+        lmt_altvolc_expl_glo)
+  IF (ierr .NE. NF_NOERR) THEN
+     PRINT*, 'Pb de lecture pour les altitudes volcan'
+     CALL exit(1)
+  ENDIF
+   ! lmt_altvolc_expl(:)=0.0
+  ierr = NF_CLOSE(nid)
+  !
+  PRINT*, 'Sources SOUFRE lues pour jour: ', jour
+  !
+  ENDIF
 !$OMP END MASTER
 !$OMP BARRIER
       call scatter( lmt_so2b_glo        , lmt_so2b )
       call scatter(lmt_so2h_glo         , lmt_so2h )
       call scatter(lmt_so2bb_h_glo      , lmt_so2bb_h )
       call scatter(lmt_so2bb_l_glo      , lmt_so2bb_l)
       call scatter(lmt_so2ba_glo        , lmt_so2ba)
       call scatter(lmt_so2nff_glo       , lmt_so2nff)
       call scatter(lmt_dmsbio_glo       , lmt_dmsbio)
       call scatter(lmt_h2sbio_glo       , lmt_h2sbio)
       call scatter(lmt_dmsconc_glo      , lmt_dmsconc)
       call scatter(lmt_dms_glo          , lmt_dms)
       call scatter(lmt_so2volc_cont_glo , lmt_so2volc_cont)
       call scatter(lmt_altvolc_cont_glo , lmt_altvolc_cont)
       call scatter(lmt_so2volc_expl_glo , lmt_so2volc_expl)
       call scatter(lmt_altvolc_expl_glo , lmt_altvolc_expl)
       RETURN
+      END
+  call scatter( lmt_so2b_glo        , lmt_so2b )
+  call scatter(lmt_so2h_glo         , lmt_so2h )
+  call scatter(lmt_so2bb_h_glo      , lmt_so2bb_h )
+  call scatter(lmt_so2bb_l_glo      , lmt_so2bb_l)
+  call scatter(lmt_so2ba_glo        , lmt_so2ba)
+  call scatter(lmt_so2nff_glo       , lmt_so2nff)
+  call scatter(lmt_dmsbio_glo       , lmt_dmsbio)
+  call scatter(lmt_h2sbio_glo       , lmt_h2sbio)
+  call scatter(lmt_dmsconc_glo      , lmt_dmsconc)
+  call scatter(lmt_dms_glo          , lmt_dms)
+  call scatter(lmt_so2volc_cont_glo , lmt_so2volc_cont)
+  call scatter(lmt_altvolc_cont_glo , lmt_altvolc_cont)
+  call scatter(lmt_so2volc_expl_glo , lmt_so2volc_expl)
+  call scatter(lmt_altvolc_expl_glo , lmt_altvolc_expl)
+  RETURN
+END SUBROUTINE condsurfs_new

LMDZ6/trunk/libf/phylmd/Dust/deposition.f90

-                      r5245
+                      r5246
 c Subroutine that estimates the Deposition velocities and the depostion
 C for the different tracers
+      subroutine deposition(vdep_oce,vdep_sic,vdep_ter,vdep_lic,pctsrf,
      .                      zrho,zdz,pdtphys,RHcl,masse,t_seri,pplay,
      .                      paprs,lminmax,qmin,qmax,
      .                        his_ds,source_tr,tr_seri)
+! Subroutine that estimates the Deposition velocities and the depostion
+! for the different tracers
+subroutine deposition(vdep_oce,vdep_sic,vdep_ter,vdep_lic,pctsrf, &
+        zrho,zdz,pdtphys,RHcl,masse,t_seri,pplay, &
+        paprs,lminmax,qmin,qmax, &
+        his_ds,source_tr,tr_seri)
       USE dimphy
       USE infotrac
       USE indice_sol_mod
+  USE dimphy
+  USE infotrac
+  USE indice_sol_mod
       IMPLICIT NONE
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
+c----------------------------- INPUT -----------------------------------
+      LOGICAL lminmax
+      REAL qmin, qmax
+      REAL vdep_oce(nbtr), vdep_sic(nbtr)
+      REAL vdep_ter(nbtr), vdep_lic(nbtr)
+      REAL pctsrf(klon,nbsrf)
+      REAL zrho(klon,klev)        !Density of air at mid points of Z (kg/m3)
+      REAL zdz(klon,klev)
+      REAL pdtphys  ! pas d'integration pour la physique (seconde)
+      REAL RHcl(klon,klev)  ! humidite relativen ciel clair
+      REAL t_seri(klon,klev)  ! temperature
+      REAL pplay(klon,klev)  ! pression pour le mileu de chaque couche (en Pa)
+      REAL paprs(klon, klev+1)    !pressure at interface of layers Z (Pa)
+      REAL masse(nbtr)
+c----------------------------- OUTPUT ----------------------------------
+      REAL his_ds(klon,nbtr)
+      REAL source_tr(klon,nbtr)
+      REAL tr_seri(klon, klev,nbtr) !conc of tracers
+c--------------------- INTERNAL VARIABLES ------------------------------
+      INTEGER i, it
+      REAL vdep        !sed. velocity
+  !----------------------------- INPUT -----------------------------------
+  LOGICAL :: lminmax
+  REAL :: qmin, qmax
+  REAL :: vdep_oce(nbtr), vdep_sic(nbtr)
+  REAL :: vdep_ter(nbtr), vdep_lic(nbtr)
+  REAL :: pctsrf(klon,nbsrf)
+  REAL :: zrho(klon,klev)        !Density of air at mid points of Z (kg/m3)
+  REAL :: zdz(klon,klev)
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+  REAL :: RHcl(klon,klev)  ! humidite relativen ciel clair
+  REAL :: t_seri(klon,klev)  ! temperature
+  REAL :: pplay(klon,klev)  ! pression pour le mileu de chaque couche (en Pa)
+  REAL :: paprs(klon, klev+1)    !pressure at interface of layers Z (Pa)
+  REAL :: masse(nbtr)
+      DO it=1, nbtr
+      DO i=1, klon
+          vdep=vdep_oce(it)*pctsrf(i,is_oce)+
+     .         vdep_sic(it)*pctsrf(i,is_sic)+
+     .         vdep_ter(it)*pctsrf(i,is_ter)+
+     .         vdep_lic(it)*pctsrf(i,is_lic)
+c--Unit: molec/m2/s for it=1 to nbtr-3, mg/m2/s for it=nbtr-2 to nbtr
+          source_tr(i,it)=source_tr(i,it)
+     .                    -vdep*tr_seri(i,1,it)*zrho(i,1)/1.e2
+          his_ds(i,it)=vdep*tr_seri(i,1,it)*zrho(i,1)/1.e2
+     .                 /RNAVO*masse(it)*1.e3               ! mg/m2/s
+      ENDDO
+      ENDDO
+c
+      END
+  !----------------------------- OUTPUT ----------------------------------
+  REAL :: his_ds(klon,nbtr)
+  REAL :: source_tr(klon,nbtr)
+  REAL :: tr_seri(klon, klev,nbtr) !conc of tracers
+  !--------------------- INTERNAL VARIABLES ------------------------------
+  INTEGER :: i, it
+  REAL :: vdep        !sed. velocity
+  DO it=1, nbtr
+  DO i=1, klon
+      vdep=vdep_oce(it)*pctsrf(i,is_oce)+ &
+            vdep_sic(it)*pctsrf(i,is_sic)+ &
+            vdep_ter(it)*pctsrf(i,is_ter)+ &
+            vdep_lic(it)*pctsrf(i,is_lic)
+  !--Unit: molec/m2/s for it=1 to nbtr-3, mg/m2/s for it=nbtr-2 to nbtr
+      source_tr(i,it)=source_tr(i,it) &
+            -vdep*tr_seri(i,1,it)*zrho(i,1)/1.e2
+      his_ds(i,it)=vdep*tr_seri(i,1,it)*zrho(i,1)/1.e2 &
+            /RNAVO*masse(it)*1.e3               ! mg/m2/s
+  ENDDO
+  ENDDO
+  !
+END SUBROUTINE deposition

LMDZ6/trunk/libf/phylmd/Dust/finemission.f90

-                      r5245
+                      r5246
 C This subroutine calculates the emissions of BLACK CARBON and ORGANIC
 C MATTER
+      SUBROUTINE finemission(zdz,pdtphys,zalt,kminbc,kmaxbc,
      .                       scale_param_bb,scale_param_ff,
      .                       iregion_ind,iregion_bb,
      .                       nbreg_ind,nbreg_bb,
      .                       lmt_bcff,lmt_bcnff,lmt_bcbb_l,lmt_bcbb_h,
      .                       lmt_bcba,lmt_omff,lmt_omnff,lmt_ombb_l,
      .                       lmt_ombb_h,lmt_omnat,lmt_omba,id_fine,
      .                                    flux_sparam_bb,flux_sparam_ff,
      .                                        source_tr,flux_tr,tr_seri)
+! This subroutine calculates the emissions of BLACK CARBON and ORGANIC
+! MATTER
+SUBROUTINE finemission(zdz,pdtphys,zalt,kminbc,kmaxbc, &
+        scale_param_bb,scale_param_ff, &
+        iregion_ind,iregion_bb, &
+        nbreg_ind,nbreg_bb, &
+        lmt_bcff,lmt_bcnff,lmt_bcbb_l,lmt_bcbb_h, &
+        lmt_bcba,lmt_omff,lmt_omnff,lmt_ombb_l, &
+        lmt_ombb_h,lmt_omnat,lmt_omba,id_fine, &
+        flux_sparam_bb,flux_sparam_ff, &
+        source_tr,flux_tr,tr_seri)
       USE dimphy
       USE indice_sol_mod
       USE infotrac
 !      USE phytracr_spl_mod, ONLY : nbreg_dust, nbreg_ind, nbreg_bb
       IMPLICIT NONE
+  USE dimphy
+  USE indice_sol_mod
+  USE infotrac
+   ! USE phytracr_spl_mod, ONLY : nbreg_dust, nbreg_ind, nbreg_bb
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
+      INTEGER i, k, kminbc, kmaxbc
+c============================= INPUT ===================================
+      REAL pdtphys  ! pas d'integration pour la physique (seconde)
+      REAL zalt(klon,klev)
+      REAL zdz(klon,klev)
+c
+c------------------------- Scaling Parameters --------------------------
+c
+      INTEGER nbreg_ind,nbreg_bb
+      INTEGER iregion_ind(klon)  !Defines regions for SO2, BC & OM
+      INTEGER iregion_bb(klon)   !Defines regions for SO2, BC & OM
+      REAL scale_param_bb(nbreg_bb) !Scaling parameter for biomas burning
+      REAL scale_param_ff(nbreg_ind) !Scaling parameter for industrial emissions (fossil fuel)
+      INTEGER id_fine
+c============================= OUTPUT ==================================
+      REAL source_tr(klon,nbtr)
+      REAL flux_tr(klon,nbtr)
+      REAL tr_seri(klon,klev,nbtr) ! traceur
+      REAL flux_sparam_bb(klon), flux_sparam_ff(klon)
+c========================= LOCAL VARIABLES =============================
+      REAL zzdz
+c------------------------- BLACK CARBON emissions ----------------------
+      REAL lmt_bcff(klon)       ! emissions de BC fossil fuels
+      REAL lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
+      REAL lmt_bcbb_l(klon)     ! emissions de BC biomass basses
+      REAL lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
+      REAL lmt_bcba(klon)       ! emissions de BC bateau
+c------------------------ ORGANIC MATTER emissions ---------------------
+      REAL lmt_omff(klon)     ! emissions de OM fossil fuels
+      REAL lmt_omnff(klon)    ! emissions de OM non-fossil fuels
+      REAL lmt_ombb_l(klon)   ! emissions de OM biomass basses
+      REAL lmt_ombb_h(klon)   ! emissions de OM biomass hautes
+      REAL lmt_omnat(klon)    ! emissions de OM Natural
+      REAL lmt_omba(klon)     ! emissions de OM bateau
+      EXTERNAL condsurfc
+c========================================================================
+c                        LOW LEVEL EMISSIONS
+c========================================================================
+c corresponds to bc_source.EQ.3
+  INTEGER :: i, k, kminbc, kmaxbc
+  !============================= INPUT ===================================
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+  REAL :: zalt(klon,klev)
+  REAL :: zdz(klon,klev)
+  !
+  !------------------------- Scaling Parameters --------------------------
+  !
+  INTEGER :: nbreg_ind,nbreg_bb
+  INTEGER :: iregion_ind(klon)  !Defines regions for SO2, BC & OM
+  INTEGER :: iregion_bb(klon)   !Defines regions for SO2, BC & OM
+  REAL :: scale_param_bb(nbreg_bb) !Scaling parameter for biomas burning
+  REAL :: scale_param_ff(nbreg_ind) !Scaling parameter for industrial emissions (fossil fuel)
+  INTEGER :: id_fine
+  !============================= OUTPUT ==================================
+  REAL :: source_tr(klon,nbtr)
+  REAL :: flux_tr(klon,nbtr)
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: flux_sparam_bb(klon), flux_sparam_ff(klon)
+  !========================= LOCAL VARIABLES =============================
+  REAL :: zzdz
+  !------------------------- BLACK CARBON emissions ----------------------
+  REAL :: lmt_bcff(klon)       ! emissions de BC fossil fuels
+  REAL :: lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
+  REAL :: lmt_bcbb_l(klon)     ! emissions de BC biomass basses
+  REAL :: lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
+  REAL :: lmt_bcba(klon)       ! emissions de BC bateau
+  !------------------------ ORGANIC MATTER emissions ---------------------
+  REAL :: lmt_omff(klon)     ! emissions de OM fossil fuels
+  REAL :: lmt_omnff(klon)    ! emissions de OM non-fossil fuels
+  REAL :: lmt_ombb_l(klon)   ! emissions de OM biomass basses
+  REAL :: lmt_ombb_h(klon)   ! emissions de OM biomass hautes
+  REAL :: lmt_omnat(klon)    ! emissions de OM Natural
+  REAL :: lmt_omba(klon)     ! emissions de OM bateau
+      DO i=1,klon
+         IF (iregion_ind(i).GT.0) THEN
+       IF(id_fine>0)    source_tr(i,id_fine)=source_tr(i,id_fine)+
+     .                (scale_param_ff(iregion_ind(i))*lmt_bcff(i)+     !g/m2/s
+     .                 scale_param_ff(iregion_ind(i))*lmt_omff(i)
+     .                 )     * 1.e4                        !g/m2/s
+c
+      IF(id_fine>0)     flux_tr(i,id_fine)=flux_tr(i,id_fine)+
+     .                (scale_param_ff(iregion_ind(i))*lmt_bcff(i)+     !mg/m2/s
+     .                 scale_param_ff(iregion_ind(i))*lmt_omff(i)
+     .                 )     * 1.e4 *1.e3                  !mg/m2/s
+c
+           flux_sparam_ff(i)= flux_sparam_ff(i) +
+     .                     scale_param_ff(iregion_ind(i))*
+     .                     ( lmt_bcff(i)+lmt_omff(i))
+     .                     *1.e4*1.e3
+         ENDIF
+         IF (iregion_bb(i).GT.0) THEN
+       IF(id_fine>0)    source_tr(i,id_fine)=source_tr(i,id_fine)+
+     .                (scale_param_bb(iregion_bb(i))*lmt_bcbb_l(i)+   !g/m2/s
+     .                 scale_param_bb(iregion_bb(i))*lmt_ombb_l(i)    !g/m2/s
+     .                 )     * 1.e4                        !g/m2/s
+c
+       IF(id_fine>0)    flux_tr(i,id_fine)=flux_tr(i,id_fine)+
+     .                (scale_param_bb(iregion_bb(i))*lmt_bcbb_l(i)+   !mg/m2/s
+     .                 scale_param_bb(iregion_bb(i))*lmt_ombb_l(i)+   !mg/m2/s
+     .                 scale_param_bb(iregion_bb(i))*lmt_bcbb_h(i)+   !mg/m2/s
+     .                 scale_param_bb(iregion_bb(i))*lmt_ombb_h(i)    !mg/m2/s
+     .                 )     * 1.e4 *1.e3                  !mg/m2/s
+c
+           flux_sparam_bb(i)=flux_sparam_bb(i) +
+     .                   scale_param_bb(iregion_bb(i))*(lmt_bcbb_l(i) +
+     .                   lmt_bcbb_h(i) + lmt_ombb_l(i) + lmt_ombb_h(i))
+     .                   *1.e4*1.e3
+         ENDIF
+       IF(id_fine>0)  source_tr(i,id_fine)=source_tr(i,id_fine)+
+     .                (lmt_bcnff(i)+lmt_bcba(i)+lmt_omnff(i)+
+     .                 lmt_omnat(i)+lmt_omba(i))     * 1.e4           !g/m2/s
+c
+       IF(id_fine>0)  flux_tr(i,id_fine)=flux_tr(i,id_fine)+
+     .                (lmt_bcnff(i)+lmt_omnff(i)+lmt_omnat(i)+
+     .                 lmt_omba(i)+lmt_bcba(i))     * 1.e4 *1.e3      !mg/m2/s
+c
+         flux_sparam_ff(i)= flux_sparam_ff(i) +
+     .                      (lmt_omba(i)+lmt_bcba(i))*1.e4*1.e3
+      ENDDO
+  EXTERNAL condsurfc
+  !========================================================================
+                     ! LOW LEVEL EMISSIONS
+  !========================================================================
+c========================================================================
+c                        HIGH LEVEL EMISSIONS
+c========================================================================
+c  Sources hautes de BC/OM
+  ! corresponds to bc_source.EQ.3
+c
+c HIGH LEVEL EMISSIONS OF SO2 ARE IN PRECUREMISSION.F
+c
+      k=2                             !introducing emissions in level 2
+cnhl      DO i = 1, klon
+c
+cnhl      tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+scale_param_ff(iregion_ind(i))*
+cnhl     .               (lmt_bcff_h(i)+lmt_omff_h(i))/zdz(i,k)/100.*pdtphys
+c
+cnhl      ENDDO
+  DO i=1,klon
+     IF (iregion_ind(i).GT.0) THEN
+   IF(id_fine>0)    source_tr(i,id_fine)=source_tr(i,id_fine)+ &
+         (scale_param_ff(iregion_ind(i))*lmt_bcff(i)+ & !g/m2/s
+         scale_param_ff(iregion_ind(i))*lmt_omff(i) &
+         )     * 1.e4                        !g/m2/s
+  !
+  IF(id_fine>0)     flux_tr(i,id_fine)=flux_tr(i,id_fine)+ &
+        (scale_param_ff(iregion_ind(i))*lmt_bcff(i)+ & !mg/m2/s
+        scale_param_ff(iregion_ind(i))*lmt_omff(i) &
+        )     * 1.e4 *1.e3                  !mg/m2/s
+  !
+       flux_sparam_ff(i)= flux_sparam_ff(i) + &
+             scale_param_ff(iregion_ind(i))* &
+             ( lmt_bcff(i)+lmt_omff(i)) &
+             *1.e4*1.e3
+     ENDIF
+     IF (iregion_bb(i).GT.0) THEN
+   IF(id_fine>0)    source_tr(i,id_fine)=source_tr(i,id_fine)+ &
+         (scale_param_bb(iregion_bb(i))*lmt_bcbb_l(i)+ & !g/m2/s
+         scale_param_bb(iregion_bb(i))*lmt_ombb_l(i) & !g/m2/s
+         )     * 1.e4                        !g/m2/s
+  !
+   IF(id_fine>0)    flux_tr(i,id_fine)=flux_tr(i,id_fine)+ &
+         (scale_param_bb(iregion_bb(i))*lmt_bcbb_l(i)+ & !mg/m2/s
+         scale_param_bb(iregion_bb(i))*lmt_ombb_l(i)+ & !mg/m2/s
+         scale_param_bb(iregion_bb(i))*lmt_bcbb_h(i)+ & !mg/m2/s
+         scale_param_bb(iregion_bb(i))*lmt_ombb_h(i) & !mg/m2/s
+         )     * 1.e4 *1.e3                  !mg/m2/s
+  !
+       flux_sparam_bb(i)=flux_sparam_bb(i) + &
+             scale_param_bb(iregion_bb(i))*(lmt_bcbb_l(i) + &
+             lmt_bcbb_h(i) + lmt_ombb_l(i) + lmt_ombb_h(i)) &
+             *1.e4*1.e3
+     ENDIF
+   IF(id_fine>0)  source_tr(i,id_fine)=source_tr(i,id_fine)+ &
+         (lmt_bcnff(i)+lmt_bcba(i)+lmt_omnff(i)+ &
+         lmt_omnat(i)+lmt_omba(i))     * 1.e4           !g/m2/s
+  !
+   IF(id_fine>0)  flux_tr(i,id_fine)=flux_tr(i,id_fine)+ &
+         (lmt_bcnff(i)+lmt_omnff(i)+lmt_omnat(i)+ &
+         lmt_omba(i)+lmt_bcba(i))     * 1.e4 *1.e3      !mg/m2/s
+  !
+     flux_sparam_ff(i)= flux_sparam_ff(i) + &
+           (lmt_omba(i)+lmt_bcba(i))*1.e4*1.e3
+  ENDDO
+      DO k=kminbc, kmaxbc
+      DO i = 1, klon
+          zzdz=zalt(i,kmaxbc+1)-zalt(i,kminbc)
+c
+         IF (iregion_bb(i) .GT.0) THEN
+        IF(id_fine>0)   tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+
+     .              (scale_param_bb(iregion_bb(i))*lmt_bcbb_h(i)+
+     .               scale_param_bb(iregion_bb(i))*lmt_ombb_h(i))
+     .                              /zzdz/100.*pdtphys
+         ENDIF
+c
+      ENDDO
+      ENDDO
+c
+      END
+  !========================================================================
+                     ! HIGH LEVEL EMISSIONS
+  !========================================================================
+  !  Sources hautes de BC/OM
+  !
+  ! HIGH LEVEL EMISSIONS OF SO2 ARE IN PRECUREMISSION.F
+  !
+  k=2                             !introducing emissions in level 2
+  !nhl      DO i = 1, klon
+  !
+  !nhl      tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+scale_param_ff(iregion_ind(i))*
+  !nhl     .               (lmt_bcff_h(i)+lmt_omff_h(i))/zdz(i,k)/100.*pdtphys
+  !
+  !nhl      ENDDO
+  DO k=kminbc, kmaxbc
+  DO i = 1, klon
+      zzdz=zalt(i,kmaxbc+1)-zalt(i,kminbc)
+  !
+     IF (iregion_bb(i) .GT.0) THEN
+    IF(id_fine>0)   tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)+ &
+          (scale_param_bb(iregion_bb(i))*lmt_bcbb_h(i)+ &
+          scale_param_bb(iregion_bb(i))*lmt_ombb_h(i)) &
+          /zzdz/100.*pdtphys
+     ENDIF
+  !
+  ENDDO
+  ENDDO
+  !
+END SUBROUTINE finemission

LMDZ6/trunk/libf/phylmd/Dust/gastoparticle.f90

-                      r5245
+                      r5246
+      SUBROUTINE gastoparticle(pdtphys,zdz,zrho,xlat,pplay,t_seri,
      .         id_prec,id_fine,
      .         tr_seri,his_g2pgas ,his_g2paer )
 cnhl     .                         fluxso4chem, flux_sparam_sulf,
+SUBROUTINE gastoparticle(pdtphys,zdz,zrho,xlat,pplay,t_seri, &
+        id_prec,id_fine, &
+        tr_seri,his_g2pgas ,his_g2paer )
+  !nhl     .                         fluxso4chem, flux_sparam_sulf,
       USE dimphy
       USE infotrac
 c      USE indice_sol_mod
+  USE dimphy
+  USE infotrac
+   ! USE indice_sol_mod
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "chem_spla.h"
       INCLUDE "YOMCST.h"
       INCLUDE "YOECUMF.h"
+c
       REAL pdtphys
       REAL zrho(klon,klev)
       REAL zdz(klon,klev)
       REAL tr_seri(klon,klev,nbtr)   ! traceurs
       REAL tend                 ! tendance par espece
       REAL xlat(klon)       ! latitudes pour chaque point
       REAL pi
 c   JE: 20140120
       REAL his_g2pgas(klon)
       REAL his_g2paer(klon)
       REAL tendincm3(klon,klev)
       REAL tempvar(klon,klev)
       REAL pplay(klon,klev)
       REAL t_seri(klon,klev)
       REAL tend2d(klon,klev)
       INTEGER id_prec,id_fine
+c
 c------------------------- Scaling Parameter --------------------------
+c
 c      REAL scale_param_so4(klon)  !Scaling parameter for sulfate
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "chem_spla.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h"
+  !
+  REAL :: pdtphys
+  REAL :: zrho(klon,klev)
+  REAL :: zdz(klon,klev)
+  REAL :: tr_seri(klon,klev,nbtr)   ! traceurs
+  REAL :: tend                 ! tendance par espece
+  REAL :: xlat(klon)       ! latitudes pour chaque point
+  REAL :: pi
+  !   JE: 20140120
+  REAL :: his_g2pgas(klon)
+  REAL :: his_g2paer(klon)
+  REAL :: tendincm3(klon,klev)
+  REAL :: tempvar(klon,klev)
+  REAL :: pplay(klon,klev)
+  REAL :: t_seri(klon,klev)
+  REAL :: tend2d(klon,klev)
+  INTEGER :: id_prec,id_fine
+  !
+  !------------------------- Scaling Parameter --------------------------
+  !
+  !  REAL scale_param_so4(klon)  !Scaling parameter for sulfate
       INTEGER i, k
       REAL tau_chem     !---chemical lifetime in s
+c
 c------------------------- Variables to save --------------------------
+c
 cnhl      REAL fluxso4chem(klon,klev)
 cnhl      REAL flux_sparam_sulf(klon,klev)
+  INTEGER :: i, k
+  REAL :: tau_chem     !---chemical lifetime in s
+  !
+  !------------------------- Variables to save --------------------------
+  !
+  !nhl      REAL fluxso4chem(klon,klev)
+  !nhl      REAL flux_sparam_sulf(klon,klev)
+c======================================================================
+      pi=atan(1.)*4.
+c
+      IF (id_prec>0 .AND. id_fine>0) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+c
+c        tau_chem=scale_param_so4(i)*86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
+cnhl        tau_chem=86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
+        tau_chem=86400.*(5.-4.*cos(xlat(i)*pi/180.))    !
+        tend=tr_seri(i,k,id_prec)*(1.-exp(-pdtphys/tau_chem)) ! Sulfate production
+cnhl        tend=(1.-exp(-pdtphys/tau_chem))
+cnhl        tend=scale_param_so4(i) !as this it works
+c
+        tr_seri(i,k,id_prec) =tr_seri(i,k,id_prec) - tend
+        tr_seri(i,k,id_fine) =tr_seri(i,k,id_fine) +
+     .                      tend/RNAVO*masse_ammsulfate  !--gAER/KgAir
+        tend2d(i,k)=tend
+c
+cnhl        fluxso4chem(i,k) = tend/RNAVO*masse_ammsulfate
+cnhl        flux_sparam_sulf(i,k) = tend/RNAVO*masse_ammsulfate
+      ENDDO
+      ENDDO
+  !======================================================================
+  pi=atan(1.)*4.
+  !
+  IF (id_prec>0 .AND. id_fine>0) THEN
+  DO k = 1, klev
+  DO i = 1, klon
+  !
+  !    tau_chem=scale_param_so4(i)*86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
+  !nhl        tau_chem=86400.*(8.-5.*cos(xlat(i)*pi/180.))    !tchemfctn2
+    tau_chem=86400.*(5.-4.*cos(xlat(i)*pi/180.))    !
+    tend=tr_seri(i,k,id_prec)*(1.-exp(-pdtphys/tau_chem)) ! Sulfate production
+  !nhl        tend=(1.-exp(-pdtphys/tau_chem))
+  !nhl        tend=scale_param_so4(i) !as this it works
+  !
+    tr_seri(i,k,id_prec) =tr_seri(i,k,id_prec) - tend
+    tr_seri(i,k,id_fine) =tr_seri(i,k,id_fine) + &
+          tend/RNAVO*masse_ammsulfate  !--gAER/KgAir
+    tend2d(i,k)=tend
+  !
+  !nhl        fluxso4chem(i,k) = tend/RNAVO*masse_ammsulfate
+  !nhl        flux_sparam_sulf(i,k) = tend/RNAVO*masse_ammsulfate
+  ENDDO
+  ENDDO
-        tempvar=tend2d
-         CALL kg_to_cm3(pplay,t_seri,tempvar)
-        tendincm3=tempvar
+      DO k = 1, klev
+      DO i = 1, klon
+    tempvar=tend2d
+     CALL kg_to_cm3(pplay,t_seri,tempvar)
+    tendincm3=tempvar
+c        his_g2pgas(i) = his_g2pgas(i) + tendincm3(i,k)*1e6*zdz(i,k)/pdtphys
+        his_g2paer(i) = his_g2paer(i) +
+     .    tendincm3(i,k)/RNAVO*masse_ammsulfate*1.e3*
+     .    1.e6*zdz(i,k)/pdtphys    ! mg/m2/s
+        his_g2pgas(i) = his_g2paer(i)*masse_s/masse_ammsulfate ! mg-S/m2/s
+  DO k = 1, klev
+  DO i = 1, klon
+      ENDDO
+      ENDDO
+      ENDIF
+     ! his_g2pgas(i) = his_g2pgas(i) + tendincm3(i,k)*1e6*zdz(i,k)/pdtphys
+    his_g2paer(i) = his_g2paer(i) + &
+          tendincm3(i,k)/RNAVO*masse_ammsulfate*1.e3* &
+.e6*zdz(i,k)/pdtphys    ! mg/m2/s
+    his_g2pgas(i) = his_g2paer(i)*masse_s/masse_ammsulfate ! mg-S/m2/s
+c
+      RETURN
+      END
+  ENDDO
+  ENDDO
+  ENDIF
+  !
+  RETURN
+END SUBROUTINE gastoparticle

LMDZ6/trunk/libf/phylmd/Dust/incloud_scav.f90

-                      r5245
+                      r5246
+c Subroutine that calculates the effect of precipitation in scavenging
 c WITHIN the cloud, for large scale as well as convective precipitation
+      SUBROUTINE incloud_scav(lminmax,qmin,qmax,masse,henry,kk,prfl,
      .                      psfl,pmflxr,pmflxs,zrho,zdz,t_seri,pdtphys,
      .                                   his_dhlsc,his_dhcon1,tr_seri)
+! Subroutine that calculates the effect of precipitation in scavenging
+! WITHIN the cloud, for large scale as well as convective precipitation
+SUBROUTINE incloud_scav(lminmax,qmin,qmax,masse,henry,kk,prfl, &
+        psfl,pmflxr,pmflxs,zrho,zdz,t_seri,pdtphys, &
+        his_dhlsc,his_dhcon1,tr_seri)
       USE dimphy
       USE infotrac
       USE indice_sol_mod
+  USE dimphy
+  USE infotrac
+  USE indice_sol_mod
       IMPLICIT NONE
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
+c============================= INPUT ===================================
+      REAL qmin, qmax
+      REAL masse(nbtr)
+      REAL henry(nbtr)         !--cste de Henry  mol/l/atm
+      REAL kk(nbtr)            !--coefficient de var avec T (K)
+      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
+!      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
+!      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+      REAL zrho(klon,klev), zdz(klon,klev)
+      REAL t_seri(klon,klev)
+      LOGICAL lminmax
+      REAL pdtphys
+!      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
+!      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
+c============================= OUTPUT ==================================
+      REAL tr_seri(klon,klev,nbtr) ! traceur
+      REAL aux_var1(klon,klev) ! traceur
+      REAL aux_var2(klon) ! traceur
+      REAL aux_var3(klon) ! traceur
+      REAL his_dhlsc(klon,nbtr)        ! in-cloud scavenging lsc
+      REAL his_dhcon1(klon,nbtr)       ! in-cloud scavenging con
+c========================= LOCAL VARIABLES =============================
+      INTEGER it, i, j
+      EXTERNAL minmaxqfi, inscav_spl
+      DO it=1, nbtr
+c
+      DO i=1,klon
+        aux_var2(i)=his_dhlsc(i,it)
+        aux_var3(i)=his_dhcon1(i,it)
+      ENDDO
+      DO j=1,klev
+      DO i=1,klon
+        aux_var1(i,j)=tr_seri(i,j,it)
+      ENDDO
+      ENDDO
+c
+      IF (lminmax) THEN
+        CALL minmaxqfi(aux_var1,qmin,qmax,'avt inscav')
+cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
+      ENDIF
+c
+cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
+cnhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
+cnhl     .             his_dhlsc(1,it))
+      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
+     .             prfl,psfl,zrho,zdz,t_seri,aux_var1,aux_var2)
+c
+      IF (lminmax) THEN
+        CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide lsc')
+cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
+      ENDIF
+c
+c
+c-scheme for convective in-cloud scavenging
+c
+cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+cnhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
+cnhl     .             his_dhcon1(1,it))
+      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+     .             pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
+c
+      IF (lminmax) THEN
+        CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
+cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
+      ENDIF
+c
+      DO j=1,klev
+      DO i=1,klon
+        tr_seri(i,j,it)=aux_var1(i,j)
+      ENDDO
+      ENDDO
+      DO i=1,klon
+        his_dhlsc(i,it)=aux_var2(i)
+        his_dhcon1(i,it)=aux_var3(i)
+      ENDDO
+  !============================= INPUT ===================================
+  REAL :: qmin, qmax
+  REAL :: masse(nbtr)
+  REAL :: henry(nbtr)         !--cste de Henry  mol/l/atm
+  REAL :: kk(nbtr)            !--coefficient de var avec T (K)
+  REAL :: prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
+   ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+  REAL :: pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
+   ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+  REAL :: zrho(klon,klev), zdz(klon,klev)
+  REAL :: t_seri(klon,klev)
+  LOGICAL :: lminmax
+  REAL :: pdtphys
+   ! REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
+   ! REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
+  !============================= OUTPUT ==================================
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: aux_var1(klon,klev) ! traceur
+  REAL :: aux_var2(klon) ! traceur
+  REAL :: aux_var3(klon) ! traceur
+  REAL :: his_dhlsc(klon,nbtr)        ! in-cloud scavenging lsc
+  REAL :: his_dhcon1(klon,nbtr)       ! in-cloud scavenging con
+  !========================= LOCAL VARIABLES =============================
+  INTEGER :: it, i, j
+c
+      ENDDO !--boucle sur it
+  EXTERNAL minmaxqfi, inscav_spl
+      END
+  DO it=1, nbtr
+  !
+  DO i=1,klon
+    aux_var2(i)=his_dhlsc(i,it)
+    aux_var3(i)=his_dhcon1(i,it)
+  ENDDO
+  DO j=1,klev
+  DO i=1,klon
+    aux_var1(i,j)=tr_seri(i,j,it)
+  ENDDO
+  ENDDO
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'avt inscav')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
+  ENDIF
+  !
+  !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
+  !nhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
+  !nhl     .             his_dhlsc(1,it))
+  CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3, &
+        prfl,psfl,zrho,zdz,t_seri,aux_var1,aux_var2)
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide lsc')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
+  ENDIF
+  !
+  !
+  !-scheme for convective in-cloud scavenging
+  !
+  !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+  !nhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
+  !nhl     .             his_dhcon1(1,it))
+  CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3, &
+        pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
+  ENDIF
+  !
+  DO j=1,klev
+  DO i=1,klon
+    tr_seri(i,j,it)=aux_var1(i,j)
+  ENDDO
+  ENDDO
+  DO i=1,klon
+    his_dhlsc(i,it)=aux_var2(i)
+    his_dhcon1(i,it)=aux_var3(i)
+  ENDDO
+  !
+  ENDDO !--boucle sur it
+END SUBROUTINE incloud_scav

LMDZ6/trunk/libf/phylmd/Dust/incloud_scav_lsc.f90

-                      r5245
+                      r5246
+c Subroutine that calculates the effect of precipitation in scavenging
 c WITHIN the cloud, for large scale as well as convective precipitation
+      SUBROUTINE incloud_scav_lsc(lminmax,qmin,qmax,masse,henry,kk,prfl,
      .                      psfl,pmflxr,pmflxs,zrho,zdz,t_seri,pdtphys,
      .                                   his_dhlsc,his_dhcon1,tr_seri)
+! Subroutine that calculates the effect of precipitation in scavenging
+! WITHIN the cloud, for large scale as well as convective precipitation
+SUBROUTINE incloud_scav_lsc(lminmax,qmin,qmax,masse,henry,kk,prfl, &
+        psfl,pmflxr,pmflxs,zrho,zdz,t_seri,pdtphys, &
+        his_dhlsc,his_dhcon1,tr_seri)
       USE dimphy
       USE infotrac
       USE indice_sol_mod
+  USE dimphy
+  USE infotrac
+  USE indice_sol_mod
       IMPLICIT NONE
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
+c============================= INPUT ===================================
+      REAL qmin, qmax
+      REAL masse(nbtr)
+      REAL henry(nbtr)         !--cste de Henry  mol/l/atm
+      REAL kk(nbtr)            !--coefficient de var avec T (K)
+      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
+!      REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
+!      REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+      REAL zrho(klon,klev), zdz(klon,klev)
+      REAL t_seri(klon,klev)
+      LOGICAL lminmax
+      REAL pdtphys
+!      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
+!      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
+c============================= OUTPUT ==================================
+      REAL tr_seri(klon,klev,nbtr) ! traceur
+      REAL aux_var1(klon,klev) ! traceur
+      REAL aux_var2(klon) ! traceur
+      REAL aux_var3(klon) ! traceur
+      REAL his_dhlsc(klon,nbtr)        ! in-cloud scavenging lsc
+      REAL his_dhcon1(klon,nbtr)       ! in-cloud scavenging con
+c========================= LOCAL VARIABLES =============================
+      INTEGER it, i, j
+      EXTERNAL minmaxqfi, inscav_spl
+      DO it=1, nbtr
+c
+      DO i=1,klon
+        aux_var2(i)=his_dhlsc(i,it)
+        aux_var3(i)=his_dhcon1(i,it)
+      ENDDO
+      DO j=1,klev
+      DO i=1,klon
+        aux_var1(i,j)=tr_seri(i,j,it)
+      ENDDO
+      ENDDO
+c
+      IF (lminmax) THEN
+        CALL minmaxqfi(aux_var1,qmin,qmax,'avt inscav')
+cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
+      ENDIF
+c
+cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
+cnhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
+cnhl     .             his_dhlsc(1,it))
+      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
+     .             prfl,psfl,zrho,zdz,t_seri,aux_var1,aux_var2)
+c
+      IF (lminmax) THEN
+        CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide lsc')
+cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
+      ENDIF
+c
+c
+c-scheme for convective in-cloud scavenging
+c
+cnhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+cnhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
+cnhl     .             his_dhcon1(1,it))
+  !============================= INPUT ===================================
+  REAL :: qmin, qmax
+  REAL :: masse(nbtr)
+  REAL :: henry(nbtr)         !--cste de Henry  mol/l/atm
+  REAL :: kk(nbtr)            !--coefficient de var avec T (K)
+  REAL :: prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale
+   ! REAL prfl(klon,klev),   psfl(klon,klev)     !--large-scale
+  REAL :: pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection
+   ! REAL pmflxr(klon,klev), pmflxs(klon,klev)   !--convection
+  REAL :: zrho(klon,klev), zdz(klon,klev)
+  REAL :: t_seri(klon,klev)
+  LOGICAL :: lminmax
+  REAL :: pdtphys
+   ! REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--large-scale  ! Titane
+   ! REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--convection   ! Titane
+  !============================= OUTPUT ==================================
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: aux_var1(klon,klev) ! traceur
+  REAL :: aux_var2(klon) ! traceur
+  REAL :: aux_var3(klon) ! traceur
+  REAL :: his_dhlsc(klon,nbtr)        ! in-cloud scavenging lsc
+  REAL :: his_dhcon1(klon,nbtr)       ! in-cloud scavenging con
+  !========================= LOCAL VARIABLES =============================
+  INTEGER :: it, i, j
+c      print *,'JE inscav0'
+c      IF (iflag_con.LT.3) THEN
+c
+c      print *,'JE inscav1'
+c      print *,'iflag_con',iflag_con
+c      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+c     .             pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
+c
+cc
+c      IF (lminmax) THEN
+c        CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
+ccnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
+c
+c      ENDIF
+c
+c      ENDIF ! iflag_con
+  EXTERNAL minmaxqfi, inscav_spl
+  DO it=1, nbtr
+  !
+  DO i=1,klon
+    aux_var2(i)=his_dhlsc(i,it)
+    aux_var3(i)=his_dhcon1(i,it)
+  ENDDO
+  DO j=1,klev
+  DO i=1,klon
+    aux_var1(i,j)=tr_seri(i,j,it)
+  ENDDO
+  ENDDO
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'avt inscav')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'avt inscav')
+  ENDIF
+  !
+  !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3,
+  !nhl     .             prfl,psfl,zrho,zdz,t_seri,tr_seri(1,1,it),
+  !nhl     .             his_dhlsc(1,it))
+  CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),0.5e-3, &
+        prfl,psfl,zrho,zdz,t_seri,aux_var1,aux_var2)
+  !
+  IF (lminmax) THEN
+    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide lsc')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide lsc')
+  ENDIF
+  !
+  !
+  !-scheme for convective in-cloud scavenging
+  !
+  !nhl      CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+  !nhl     .             pmflxr,pmflxs,zrho,zdz,t_seri,tr_seri(1,1,it),
+  !nhl     .             his_dhcon1(1,it))
+c
+c      print *,'JE inscav2'
+      DO j=1,klev
+      DO i=1,klon
+        tr_seri(i,j,it)=aux_var1(i,j)
+      ENDDO
+      ENDDO
+      DO i=1,klon
+        his_dhlsc(i,it)=aux_var2(i)
+        his_dhcon1(i,it)=aux_var3(i)
+      ENDDO
+  !  print *,'JE inscav0'
+  !  IF (iflag_con.LT.3) THEN
+  !
+  !  print *,'JE inscav1'
+  !  print *,'iflag_con',iflag_con
+  !  CALL inscav_spl(pdtphys,it,masse(it),henry(it),kk(it),1.e-3,
+  ! .             pmflxr,pmflxs,zrho,zdz,t_seri,aux_var1,aux_var3)
+  !
+  !c
+  !  IF (lminmax) THEN
+  !    CALL minmaxqfi(aux_var1,qmin,qmax,'depot humide con')
+  !cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'depot humide con')
+  !
+  !  ENDIF
+  !
+  !  ENDIF ! iflag_con
+c
+      ENDDO !--boucle sur it
+  !
+  !  print *,'JE inscav2'
+  DO j=1,klev
+  DO i=1,klon
+    tr_seri(i,j,it)=aux_var1(i,j)
+  ENDDO
+  ENDDO
+  DO i=1,klon
+    his_dhlsc(i,it)=aux_var2(i)
+    his_dhcon1(i,it)=aux_var3(i)
+  ENDDO
+c      print *,'JE inscav3'
+      END
+  !
+  ENDDO !--boucle sur it
+   ! print *,'JE inscav3'
+END SUBROUTINE incloud_scav_lsc

LMDZ6/trunk/libf/phylmd/Dust/inscav_spl.f90

-                      r5245
+                      r5246
+      SUBROUTINE inscav_spl(pdtime,it,masse,henry,kk,qliq,
      .                   flxr,flxs,zrho,zdz,t,x,
      .                   his_dh)
       USE dimphy
       IMPLICIT NONE
 c=====================================================================
 c Objet : depot humide de traceurs
 c Date : mars 1998
+c Auteur: O. Boucher (LOA)
 c=====================================================================
+c
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "YOECUMF.h"
+c
       INTEGER it
       REAL pdtime              ! pas de temps (s)
       REAL masse               ! molar mass (except for BC/OM/IF/DUST=Nav)
       REAL henry               ! constante de Henry en mol/l/atm
       REAL kk                  ! coefficient de dependence en T (K)
       REAL qliq                ! contenu en eau liquide dans le nuage (kg/kg)
 !      REAL flxr(klon,klev+1)   ! flux precipitant de pluie
 !      REAL flxs(klon,klev+1)   ! flux precipitant de neige
       REAL flxr(klon,klev)   ! flux precipitant de pluie   ! Titane
       REAL flxs(klon,klev)   ! flux precipitant de neige   ! Titane
       REAL flxr_aux(klon,klev+1)
       REAL flxs_aux(klon,klev+1)
       REAL zrho(klon,klev)
       REAL zdz(klon,klev)
       REAL t(klon,klev)
       REAL x(klon,klev)        ! q de traceur
       REAL his_dh(klon)        ! tendance de traceur integre verticalement
+c
+c--variables locales
       INTEGER i, k
+c
       REAL dx      ! tendance de traceur
       REAL f_a     !--rapport de la phase aqueuse a la phase gazeuse
       REAL beta    !--taux de conversion de l'eau en pluie
       REAL henry_t !--constante de Henry a T t  (mol/l/atm)
       REAL scav(klon,klev)    !--fraction aqueuse du constituant
       REAL K1, K2, ph, frac
       REAL frac_gas, frac_aer !-cste pour la reevaporation
       PARAMETER (ph=5., frac_gas=1.0, frac_aer=0.5)
 c---cste de dissolution pour le depot humide
       REAL frac_fine_scav,frac_coar_scav
 c---added by nhl
       REAL aux_cte
+SUBROUTINE inscav_spl(pdtime,it,masse,henry,kk,qliq, &
+        flxr,flxs,zrho,zdz,t,x, &
+        his_dh)
+  USE dimphy
+  IMPLICIT NONE
+  !=====================================================================
+  ! Objet : depot humide de traceurs
+  ! Date : mars 1998
+  ! Auteur: O. Boucher (LOA)
+  !=====================================================================
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h"
+  !
+  INTEGER :: it
+  REAL :: pdtime              ! pas de temps (s)
+  REAL :: masse               ! molar mass (except for BC/OM/IF/DUST=Nav)
+  REAL :: henry               ! constante de Henry en mol/l/atm
+  REAL :: kk                  ! coefficient de dependence en T (K)
+  REAL :: qliq                ! contenu en eau liquide dans le nuage (kg/kg)
+   ! REAL flxr(klon,klev+1)   ! flux precipitant de pluie
+   ! REAL flxs(klon,klev+1)   ! flux precipitant de neige
+  REAL :: flxr(klon,klev)   ! flux precipitant de pluie   ! Titane
+  REAL :: flxs(klon,klev)   ! flux precipitant de neige   ! Titane
+  REAL :: flxr_aux(klon,klev+1)
+  REAL :: flxs_aux(klon,klev+1)
+  REAL :: zrho(klon,klev)
+  REAL :: zdz(klon,klev)
+  REAL :: t(klon,klev)
+  REAL :: x(klon,klev)        ! q de traceur
+  REAL :: his_dh(klon)        ! tendance de traceur integre verticalement
+  !
+  !--variables locales
+  INTEGER :: i, k
+  !
+  REAL :: dx      ! tendance de traceur
+  REAL :: f_a     !--rapport de la phase aqueuse a la phase gazeuse
+  REAL :: beta    !--taux de conversion de l'eau en pluie
+  REAL :: henry_t !--constante de Henry a T t  (mol/l/atm)
+  REAL :: scav(klon,klev)    !--fraction aqueuse du constituant
+  REAL :: K1, K2, ph, frac
+  REAL :: frac_gas, frac_aer !-cste pour la reevaporation
+  PARAMETER (ph=5., frac_gas=1.0, frac_aer=0.5)
+  !---cste de dissolution pour le depot humide
+  REAL :: frac_fine_scav,frac_coar_scav
+  !---added by nhl
+  REAL :: aux_cte
       PARAMETER (frac_fine_scav=0.7)
       PARAMETER (frac_coar_scav=0.7)
+  PARAMETER (frac_fine_scav=0.7)
+  PARAMETER (frac_coar_scav=0.7)
 c--101.325  m3/l x Pa/atm
 c--R        Pa.m3/mol/K
+c
 c------------------------------------------
+c
 cnhl      IF (it.EQ.2.OR.it.EQ.3) THEN !--aerosol  ! AS IT WAS FIRST
       IF (it.EQ.2.OR.it.EQ.3.OR.it.EQ.4) THEN !--aerosol
         frac=frac_aer
       ELSE                                                !--gas
         frac=frac_gas
       ENDIF
+c
       IF (it.EQ.1) THEN
       DO k=1, klev
       DO i=1, klon
         henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !--mol/l/atm
         K1=1.2e-2*exp(-2010*(1/298.-1/t(i,k)))
         K2=6.6e-8*exp(-1510*(1/298.-1/t(i,k)))
         henry_t=henry_t*(1 + K1/10.**(-ph) + K1*K2/(10.**(-ph))**2)
         f_a=henry_t/101.325*R*t(i,k)*qliq*zrho(i,k)/rho_water
         scav(i,k)=f_a/(1.+f_a)
       ENDDO
       ENDDO
       ELSEIF (it.EQ.2) THEN
       DO k=1, klev
       DO i=1, klon
         scav(i,k)=frac_fine_scav
       ENDDO
       ENDDO
       ELSEIF (it.EQ.3) THEN
       DO k=1, klev
       DO i=1, klon
         scav(i,k)=frac_coar_scav
       ENDDO
       ENDDO
       ELSEIF (it.EQ.4) THEN
       DO k=1, klev
       DO i=1, klon
         scav(i,k)=frac_coar_scav
       ENDDO
       ENDDO
       ELSE
         PRINT *,'it non pris en compte'
         STOP
       ENDIF
+c
 ! NHL
 ! Auxiliary variables defined to deal with the fact that precipitation
 ! fluxes are defined on klev levels only.
 ! NHL
+!
       flxr_aux(:,klev+1)=0.0
       flxs_aux(:,klev+1)=0.0
       flxr_aux(:,1:klev)=flxr(:,:)
       flxs_aux(:,1:klev)=flxs(:,:)
       DO k=klev, 1, -1
       DO i=1, klon
 c--scavenging
         beta=flxr_aux(i,k)-flxr_aux(i,k+1)+flxs_aux(i,k)-flxs_aux(i,k+1)
         beta=beta/zdz(i,k)/qliq/zrho(i,k)
         beta=MAX(0.0,beta)
         dx=x(i,k)*(exp(-scav(i,k)*beta*pdtime)-1.)
         x(i,k)=x(i,k)+dx
         his_dh(i)=his_dh(i)-dx/RNAVO*
      .            masse*1.e3*1.e6*zdz(i,k)/pdtime !--mgS/m2/s
 c--reevaporation
         beta=flxr_aux(i,k)-flxr_aux(i,k+1)+flxs_aux(i,k)-flxs_aux(i,k+1)
         IF (beta.LT.0.) beta=beta/(flxr_aux(i,k+1)+flxs_aux(i,k+1))
         IF (flxr_aux(i,k)+flxs_aux(i,k).EQ.0) THEN  !--reevaporation totale
           beta=MIN(MAX(0.0,-beta),1.0)
         ELSE                          !--reevaporation non totale pour aerosols
           !print *,'FRAC USED IN INSCAV_SPL'
           beta=MIN(MAX(0.0,-beta)*frac,1.0)
         ENDIF
         dx=beta*his_dh(i)*RNAVO/masse/1.e3/1.e6/zdz(i,k)*pdtime !ORIG LINE
 ! funny line for TL/AD
 ! AD test works without (x) and for xd = dxd*1.e5 : 2.79051851638 times the 0.
 ! AD test does not work with the line : 754592404.083 times the 0.
 ! problem seems to be linked to the largest dx wrt x
 !       x(i, k) = x(i, k) + dx
 !        x(i, k) = x(i, k) + dx         ! THIS LINE WAS COMMENTED OUT ORIGINALY !nhl
         his_dh(i)=(1.-beta)*his_dh(i)
       ENDDO
       ENDDO
+c
       RETURN
+      END
+  !--101.325  m3/l x Pa/atm
+  !--R        Pa.m3/mol/K
+  !
+  !------------------------------------------
+  !
+  !nhl      IF (it.EQ.2.OR.it.EQ.3) THEN !--aerosol  ! AS IT WAS FIRST
+  IF (it.EQ.2.OR.it.EQ.3.OR.it.EQ.4) THEN !--aerosol
+    frac=frac_aer
+  ELSE                                                !--gas
+    frac=frac_gas
+  ENDIF
+  !
+  IF (it.EQ.1) THEN
+  DO k=1, klev
+  DO i=1, klon
+    henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !--mol/l/atm
+    K1=1.2e-2*exp(-2010*(1/298.-1/t(i,k)))
+    K2=6.6e-8*exp(-1510*(1/298.-1/t(i,k)))
+    henry_t=henry_t*(1 + K1/10.**(-ph) + K1*K2/(10.**(-ph))**2)
+    f_a=henry_t/101.325*R*t(i,k)*qliq*zrho(i,k)/rho_water
+    scav(i,k)=f_a/(1.+f_a)
+  ENDDO
+  ENDDO
+  ELSEIF (it.EQ.2) THEN
+  DO k=1, klev
+  DO i=1, klon
+    scav(i,k)=frac_fine_scav
+  ENDDO
+  ENDDO
+  ELSEIF (it.EQ.3) THEN
+  DO k=1, klev
+  DO i=1, klon
+    scav(i,k)=frac_coar_scav
+  ENDDO
+  ENDDO
+  ELSEIF (it.EQ.4) THEN
+  DO k=1, klev
+  DO i=1, klon
+    scav(i,k)=frac_coar_scav
+  ENDDO
+  ENDDO
+  ELSE
+    PRINT *,'it non pris en compte'
+    STOP
+  ENDIF
+  !
+  ! NHL
+  ! Auxiliary variables defined to deal with the fact that precipitation
+  ! fluxes are defined on klev levels only.
+  ! NHL
+  !
+  flxr_aux(:,klev+1)=0.0
+  flxs_aux(:,klev+1)=0.0
+  flxr_aux(:,1:klev)=flxr(:,:)
+  flxs_aux(:,1:klev)=flxs(:,:)
+  DO k=klev, 1, -1
+  DO i=1, klon
+  !--scavenging
+    beta=flxr_aux(i,k)-flxr_aux(i,k+1)+flxs_aux(i,k)-flxs_aux(i,k+1)
+    beta=beta/zdz(i,k)/qliq/zrho(i,k)
+    beta=MAX(0.0,beta)
+    dx=x(i,k)*(exp(-scav(i,k)*beta*pdtime)-1.)
+    x(i,k)=x(i,k)+dx
+    his_dh(i)=his_dh(i)-dx/RNAVO* &
+          masse*1.e3*1.e6*zdz(i,k)/pdtime !--mgS/m2/s
+  !--reevaporation
+    beta=flxr_aux(i,k)-flxr_aux(i,k+1)+flxs_aux(i,k)-flxs_aux(i,k+1)
+    IF (beta.LT.0.) beta=beta/(flxr_aux(i,k+1)+flxs_aux(i,k+1))
+    IF (flxr_aux(i,k)+flxs_aux(i,k).EQ.0) THEN  !--reevaporation totale
+      beta=MIN(MAX(0.0,-beta),1.0)
+    ELSE                          !--reevaporation non totale pour aerosols
+      ! !print *,'FRAC USED IN INSCAV_SPL'
+      beta=MIN(MAX(0.0,-beta)*frac,1.0)
+    ENDIF
+    dx=beta*his_dh(i)*RNAVO/masse/1.e3/1.e6/zdz(i,k)*pdtime !ORIG LINE
+  ! funny line for TL/AD
+  ! AD test works without (x) and for xd = dxd*1.e5 : 2.79051851638 times the 0.
+  ! AD test does not work with the line : 754592404.083 times the 0.
+  ! problem seems to be linked to the largest dx wrt x
+    ! x(i, k) = x(i, k) + dx
+    !  x(i, k) = x(i, k) + dx         ! THIS LINE WAS COMMENTED OUT ORIGINALY !nhl
+    his_dh(i)=(1.-beta)*his_dh(i)
+  ENDDO
+  ENDDO
+  !
+  RETURN
+END SUBROUTINE inscav_spl

LMDZ6/trunk/libf/phylmd/Dust/kg_to_cm3.f90

-                      r5245
+                      r5246
       SUBROUTINE kg_to_cm3(pplay,t_seri,tr_seri)
+c
       USE dimphy
       USE infotrac
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "YOMCST.h"
+c
       REAL t_seri(klon,klev), pplay(klon,klev)
       REAL tr_seri(klon,klev)
       REAL zrho
       INTEGER i, k
+c
       DO k = 1, klev
       DO i = 1, klon
         zrho=pplay(i,k)/t_seri(i,k)/RD
         tr_seri(i,k)=tr_seri(i,k)/1.e6*zrho
       ENDDO
       ENDDO
+c
+      END
+SUBROUTINE kg_to_cm3(pplay,t_seri,tr_seri)
+  !
+  USE dimphy
+  USE infotrac
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "YOMCST.h"
+  !
+  REAL :: t_seri(klon,klev), pplay(klon,klev)
+  REAL :: tr_seri(klon,klev)
+  REAL :: zrho
+  INTEGER :: i, k
+  !
+  DO k = 1, klev
+  DO i = 1, klon
+    zrho=pplay(i,k)/t_seri(i,k)/RD
+    tr_seri(i,k)=tr_seri(i,k)/1.e6*zrho
+  ENDDO
+  ENDDO
+  !
+END SUBROUTINE kg_to_cm3

LMDZ6/trunk/libf/phylmd/Dust/minmaxqfi2.f90

-                      r5245
+                      r5246
       subroutine minmaxqfi2(zq,qmin,qmax,comment)
+c
       USE dimphy
       USE infotrac
       INCLUDE "dimensions.h"
+subroutine minmaxqfi2(zq,qmin,qmax,comment)
+  !
+  USE dimphy
+  USE infotrac
+  INCLUDE "dimensions.h"
 !      character*20 comment
       character*(*) comment
       real qmin,qmax
       real zq(klon,klev)
+   ! character*20 comment
+  character(len=*) :: comment
+  real :: qmin,qmax
+  real :: zq(klon,klev)
       integer ijmin, lmin, ijlmin
       integer ijmax, lmax, ijlmax
+  integer :: ijmin, lmin, ijlmin
+  integer :: ijmax, lmax, ijlmax
       integer ismin,ismax
+  integer :: ismin,ismax
       ijlmin=ismin(klon*klev,zq,1)
       lmin=(ijlmin-1)/klon+1
       ijmin=ijlmin-(lmin-1)*klon
       zqmin=zq(ijmin,lmin)
+  ijlmin=ismin(klon*klev,zq,1)
+  lmin=(ijlmin-1)/klon+1
+  ijmin=ijlmin-(lmin-1)*klon
+  zqmin=zq(ijmin,lmin)
+      ijlmax=ismax(klon*klev,zq,1)
+      lmax=(ijlmax-1)/klon+1
+      ijmax=ijlmax-(lmax-1)*klon
+      zqmax=zq(ijmax,lmax)
+      if(zqmin.lt.qmin.or.zqmax.gt.qmax)
+     s     write(*,9999) comment,
+     s     ijmin,lmin,zqmin,ijmax,lmax,zqmax
+  ijlmax=ismax(klon*klev,zq,1)
+  lmax=(ijlmax-1)/klon+1
+  ijmax=ijlmax-(lmax-1)*klon
+  zqmax=zq(ijmax,lmax)
+      return
+  format(a20,2('  q(',i4,',',i2,')=',e12.5))
+      end
+  if(zqmin.lt.qmin.or.zqmax.gt.qmax) &
+        write(*,9999) comment, &
+        ijmin,lmin,zqmin,ijmax,lmax,zqmax
+  return
+   format(a20,2('  q(',i4,',',i2,')=',e12.5))
+end subroutine minmaxqfi2

LMDZ6/trunk/libf/phylmd/Dust/minmaxsource.f90

-                      r5245
+                      r5246
       subroutine minmaxsource(zq,qmin,qmax,comment)
+subroutine minmaxsource(zq,qmin,qmax,comment)
       USE dimphy
       USE infotrac
+  USE dimphy
+  USE infotrac
       INCLUDE "dimensions.h"
+  INCLUDE "dimensions.h"
 !      character*20 comment
       character*(*) comment
       real qmin,qmax
       real zq(klon,nbtr)
+   ! character*20 comment
+  character(len=*) :: comment
+  real :: qmin,qmax
+  real :: zq(klon,nbtr)
       integer ijmin, lmin, ijlmin
       integer ijmax, lmax, ijlmax
+  integer :: ijmin, lmin, ijlmin
+  integer :: ijmax, lmax, ijlmax
       integer ismin,ismax
+  integer :: ismin,ismax
       ijlmin=ismin(klon*nbtr,zq,1)
       lmin=(ijlmin-1)/klon+1
       ijmin=ijlmin-(lmin-1)*klon
       zqmin=zq(ijmin,lmin)
+  ijlmin=ismin(klon*nbtr,zq,1)
+  lmin=(ijlmin-1)/klon+1
+  ijmin=ijlmin-(lmin-1)*klon
+  zqmin=zq(ijmin,lmin)
       ijlmax=ismax(klon*nbtr,zq,1)
       lmax=(ijlmax-1)/klon+1
       ijmax=ijlmax-(lmax-1)*klon
       zqmax=zq(ijmax,lmax)
+  ijlmax=ismax(klon*nbtr,zq,1)
+  lmax=(ijlmax-1)/klon+1
+  ijmax=ijlmax-(lmax-1)*klon
+  zqmax=zq(ijmax,lmax)
       if(zqmin.lt.qmin.or.zqmax.gt.qmax)
      s     write(*,9999) comment,
      s     ijmin,lmin,zqmin,ijmax,lmax,zqmax
+  if(zqmin.lt.qmin.or.zqmax.gt.qmax) &
+        write(*,9999) comment, &
+        ijmin,lmin,zqmin,ijmax,lmax,zqmax
       return
   format(a20,2('  q(',i4,',',i2,')=',e12.5))
+      end
+  return
+   format(a20,2('  q(',i4,',',i2,')=',e12.5))
+end subroutine minmaxsource

LMDZ6/trunk/libf/phylmd/Dust/neutral.f90

-                      r5245
+                      r5246
+c***********************************************************************
+        subroutine neutral(u10_mps,ustar_mps,obklen_m,
      +         u10n_mps )
 c-----------------------------------------------------------------------
 c subroutine to compute u10 neutral wind speed
 c inputs
 c       u10_mps - wind speed at 10 m (m/s)
 c       ustar_mps - friction velocity (m/s)
 c       obklen_m - monin-obukhov length scale (m)
 c outputs
 c       u10n_mps - wind speed at 10 m under neutral conditions (m/s)
 c following code assumes reference height Z is 10m, consistent with use
 c of u10 and u10_neutral.  If not, code
 c should be changed so that constants of 50. and 160. in equations
 c below are changed to -5 * Z and -16 * Z respectively.
+c Reference:  G. L. Geernaert.  'Bulk parameterizations for the
 c wind stress and heat fluxes,' in Surface Waves and Fluxes, Vol. I,
 c Current Theory, Geernaert and W.J. Plant, editors, Kluwer Academic
 c Publishers, Boston, MA, 1990.
 c subroutine written Feb 2001 by eg chapman
 c adapted to LMD-ZT by E. Cosme 310801
 c Following Will Shaw (PNL, Seattle) the theory applied for flux
 c calculation with the scheme of Nightingale et al. (2000) does not
 c hold anymore when -1<obklen<20. In this case, u10n is set to 0,
 c so that the transfer velocity  computed in nightingale.F will also
 c be 0. The flux is then set to 0.
 c----------------------------------------------------------------------
+c
       USE dimphy
       INCLUDE "dimensions.h"
+c
         real u10_mps(klon),ustar_mps(klon),obklen_m(klon)
         real u10n_mps(klon)
         real pi,von_karman
 c       parameter (pi = 3.141592653589793, von_karman = 0.4)
 c pour etre coherent avec vk de bl_for_dms.F
         parameter (pi = 3.141592653589793, von_karman = 0.35)
+c
         real phi, phi_inv, phi_inv_sq, f1, f2, f3, dum1, psi
         integer i
+!***********************************************************************
+  subroutine neutral(u10_mps,ustar_mps,obklen_m, &
+          u10n_mps )
+  !-----------------------------------------------------------------------
+  ! subroutine to compute u10 neutral wind speed
+  ! inputs
+  ! u10_mps - wind speed at 10 m (m/s)
+  ! ustar_mps - friction velocity (m/s)
+  ! obklen_m - monin-obukhov length scale (m)
+  ! outputs
+  ! u10n_mps - wind speed at 10 m under neutral conditions (m/s)
+  ! following code assumes reference height Z is 10m, consistent with use
+  ! of u10 and u10_neutral.  If not, code
+  ! should be changed so that constants of 50. and 160. in equations
+  ! below are changed to -5 * Z and -16 * Z respectively.
+  ! Reference:  G. L. Geernaert.  'Bulk parameterizations for the
+  ! wind stress and heat fluxes,' in Surface Waves and Fluxes, Vol. I,
+  ! Current Theory, Geernaert and W.J. Plant, editors, Kluwer Academic
+  ! Publishers, Boston, MA, 1990.
+  ! subroutine written Feb 2001 by eg chapman
+  ! adapted to LMD-ZT by E. Cosme 310801
+  ! Following Will Shaw (PNL, Seattle) the theory applied for flux
+  ! calculation with the scheme of Nightingale et al. (2000) does not
+  ! hold anymore when -1<obklen<20. In this case, u10n is set to 0,
+  ! so that the transfer velocity  computed in nightingale.F will also
+  ! be 0. The flux is then set to 0.
+  !----------------------------------------------------------------------
+  !
+  USE dimphy
+  INCLUDE "dimensions.h"
+  !
+    real :: u10_mps(klon),ustar_mps(klon),obklen_m(klon)
+    real :: u10n_mps(klon)
+    real :: pi,von_karman
+    ! parameter (pi = 3.141592653589793, von_karman = 0.4)
+  ! pour etre coherent avec vk de bl_for_dms.F
+    parameter (pi = 3.141592653589793, von_karman = 0.35)
+  !
+    real :: phi, phi_inv, phi_inv_sq, f1, f2, f3, dum1, psi
+    integer :: i
         psi = 0.
         do i=1,klon
+    psi = 0.
+    do i=1,klon
+        if (u10_mps(i) .lt. 0.) u10_mps(i) = 0.0
+        if  (obklen_m(i) .lt. 0.) then
+                phi = (1. - 160./obklen_m(i))**(-0.25)
+                phi_inv = 1./phi
+                phi_inv_sq = 1./phi * 1./phi
+                f1 = (1. + phi_inv) / 2.
+                f2 = (1. + phi_inv_sq)/2.
+c following to avoid numerical overruns. recall tan(90deg)=infinity
+                dum1 = min (1.e24, phi_inv)
+                f3 = atan(dum1)
+                psi = 2.*log(f1) + log(f2) - 2.*f3 + pi/2.
+        else if (obklen_m(i) .gt. 0.) then
+                psi = -50. / obklen_m(i)
+        end if
+    if (u10_mps(i) .lt. 0.) u10_mps(i) = 0.0
+        u10n_mps(i) = u10_mps(i) + (ustar_mps(i) * psi /von_karman )
+c u10n set to 0. if -1 < obklen < 20
+        if ((obklen_m(i).gt.-1.).and.(obklen_m(i).lt.20.)) then
+            u10n_mps(i) = 0.
+        endif
+        if (u10n_mps(i) .lt. 0.) u10n_mps(i) = 0.0
+    if  (obklen_m(i) .lt. 0.) then
+            phi = (1. - 160./obklen_m(i))**(-0.25)
+            phi_inv = 1./phi
+            phi_inv_sq = 1./phi * 1./phi
+            f1 = (1. + phi_inv) / 2.
+            f2 = (1. + phi_inv_sq)/2.
+  ! following to avoid numerical overruns. recall tan(90deg)=infinity
+            dum1 = min (1.e24, phi_inv)
+            f3 = atan(dum1)
+            psi = 2.*log(f1) + log(f2) - 2.*f3 + pi/2.
+    else if (obklen_m(i) .gt. 0.) then
+            psi = -50. / obklen_m(i)
+    end if
+        enddo
+        return
+        end
+c***********************************************************************
+    u10n_mps(i) = u10_mps(i) + (ustar_mps(i) * psi /von_karman )
+  ! u10n set to 0. if -1 < obklen < 20
+    if ((obklen_m(i).gt.-1.).and.(obklen_m(i).lt.20.)) then
+        u10n_mps(i) = 0.
+    endif
+    if (u10n_mps(i) .lt. 0.) u10n_mps(i) = 0.0
+    enddo
+    return
+end subroutine neutral
+!***********************************************************************

LMDZ6/trunk/libf/phylmd/Dust/nightingale.f90

-                      r5245
+                      r5246
+      SUBROUTINE nightingale(u, v, u_10m, v_10m, paprs, pplay,
      .                       cdragh, cdragm, t, q, ftsol, tsol,
      .                       pctsrf, lmt_dmsconc, lmt_dms)
+c
       USE dimphy
       USE indice_sol_mod
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "YOMCST.h"
+c
       REAL u(klon,klev), v(klon,klev)
       REAL u_10m(klon), v_10m(klon)
       REAL ftsol(klon,nbsrf)
       REAL tsol(klon)
       REAL paprs(klon,klev+1), pplay(klon,klev)
       REAL t(klon,klev)
       REAL q(klon,klev)
       REAL cdragh(klon), cdragm(klon)
       REAL pctsrf(klon,nbsrf)
       REAL lmt_dmsconc(klon)  ! concentration oceanique DMS
       REAL lmt_dms(klon)      ! flux de DMS
+c
       REAL ustar(klon), obklen(klon)
       REAL u10(klon), u10n(klon)
       REAL tvelocity, schmidt_corr
       REAL t1, t2, t3, t4, viscosity_kin, diffusivity, schmidt
       INTEGER i
+c
       CALL bl_for_dms(u, v, paprs, pplay, cdragh, cdragm,
      .                t, q, tsol, ustar, obklen)
+c
       DO i=1,klon
         u10(i)=SQRT(u_10m(i)**2+v_10m(i)**2)
       ENDDO
+c
       CALL neutral(u10, ustar, obklen, u10n)
+c
       DO i=1,klon
+c
 c       tvelocity - transfer velocity, also known as kw (cm/s)
 c       schmidt_corr - Schmidt number correction factor (dimensionless)
 c Reference:  Nightingale, P.D., G. Malin, C. S. Law, J. J. Watson, P.S. Liss
+c  M. I. Liddicoat, J. Boutin, R.C. Upstill-Goddard. 'In situ evaluation
+c  of air-sea gas exchange parameterizations using conservative and
 c  volatile tracers.'  Glob. Biogeochem. Cycles, 14:373-387, 2000.
+c compute transfer velocity using u10neutral
+c
       tvelocity = 0.222*u10n(i)*u10n(i) + 0.333*u10n(i)
+c
 c above expression gives tvelocity in cm/hr. convert to cm/s. 1hr =3600 sec
+SUBROUTINE nightingale(u, v, u_10m, v_10m, paprs, pplay, &
+        cdragh, cdragm, t, q, ftsol, tsol, &
+        pctsrf, lmt_dmsconc, lmt_dms)
+  !
+  USE dimphy
+  USE indice_sol_mod
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "YOMCST.h"
+  !
+  REAL :: u(klon,klev), v(klon,klev)
+  REAL :: u_10m(klon), v_10m(klon)
+  REAL :: ftsol(klon,nbsrf)
+  REAL :: tsol(klon)
+  REAL :: paprs(klon,klev+1), pplay(klon,klev)
+  REAL :: t(klon,klev)
+  REAL :: q(klon,klev)
+  REAL :: cdragh(klon), cdragm(klon)
+  REAL :: pctsrf(klon,nbsrf)
+  REAL :: lmt_dmsconc(klon)  ! concentration oceanique DMS
+  REAL :: lmt_dms(klon)      ! flux de DMS
+  !
+  REAL :: ustar(klon), obklen(klon)
+  REAL :: u10(klon), u10n(klon)
+  REAL :: tvelocity, schmidt_corr
+  REAL :: t1, t2, t3, t4, viscosity_kin, diffusivity, schmidt
+  INTEGER :: i
+  !
+  CALL bl_for_dms(u, v, paprs, pplay, cdragh, cdragm, &
+        t, q, tsol, ustar, obklen)
+  !
+  DO i=1,klon
+    u10(i)=SQRT(u_10m(i)**2+v_10m(i)**2)
+  ENDDO
+  !
+  CALL neutral(u10, ustar, obklen, u10n)
+  !
+  DO i=1,klon
+  !
+  ! tvelocity - transfer velocity, also known as kw (cm/s)
+  ! schmidt_corr - Schmidt number correction factor (dimensionless)
+  ! Reference:  Nightingale, P.D., G. Malin, C. S. Law, J. J. Watson, P.S. Liss
+  !  M. I. Liddicoat, J. Boutin, R.C. Upstill-Goddard. 'In situ evaluation
+  !  of air-sea gas exchange parameterizations using conservative and
+  !  volatile tracers.'  Glob. Biogeochem. Cycles, 14:373-387, 2000.
+  ! compute transfer velocity using u10neutral
+  !
+  tvelocity = 0.222*u10n(i)*u10n(i) + 0.333*u10n(i)
+  !
+  ! above expression gives tvelocity in cm/hr. convert to cm/s. 1hr =3600 sec
       tvelocity = tvelocity / 3600.
+  tvelocity = tvelocity / 3600.
+c compute the correction factor, which for Nightingale parameterization is
+c based on how different the schmidt number is from 600.
 c correction factor based on temperature in Kelvin. good
 c only for t<=30 deg C.  for temperatures above that, set correction factor
 c equal to value at 30 deg C.
+  ! compute the correction factor, which for Nightingale parameterization is
+  ! based on how different the schmidt number is from 600.
+  ! correction factor based on temperature in Kelvin. good
+  ! only for t<=30 deg C.  for temperatures above that, set correction factor
+  ! equal to value at 30 deg C.
       IF (ftsol(i,is_oce) .LE. 303.15) THEN
          t1 = ftsol(i,is_oce)
       ELSE
          t1 = 303.15
       ENDIF
+  IF (ftsol(i,is_oce) .LE. 303.15) THEN
+     t1 = ftsol(i,is_oce)
+  ELSE
+     t1 = 303.15
+  ENDIF
       t2 = t1 * t1
       t3 = t2 * t1
       t4 = t3 * t1
       viscosity_kin = 3.0363e-9*t4 - 3.655198e-6*t3 + 1.65333e-3*t2
      +      - 3.332083e-1*t1 + 25.26819
       diffusivity = 0.01922 * exp(-2177.1/t1)
       schmidt = viscosity_kin / diffusivity
       schmidt_corr = (schmidt/600.)**(-.5)
+c
       lmt_dms(i) = tvelocity  *  pctsrf(i,is_oce)
      .        * lmt_dmsconc(i)/1.0e12 * schmidt_corr * RNAVO
+c
       IF (lmt_dmsconc(i).LE.1.e-20) lmt_dms(i)=0.0
+c
       ENDDO
+c
+      END
+  t2 = t1 * t1
+  t3 = t2 * t1
+  t4 = t3 * t1
+  viscosity_kin = 3.0363e-9*t4 - 3.655198e-6*t3 + 1.65333e-3*t2 &
+        - 3.332083e-1*t1 + 25.26819
+  diffusivity = 0.01922 * exp(-2177.1/t1)
+  schmidt = viscosity_kin / diffusivity
+  schmidt_corr = (schmidt/600.)**(-.5)
+  !
+  lmt_dms(i) = tvelocity  *  pctsrf(i,is_oce) &
+        * lmt_dmsconc(i)/1.0e12 * schmidt_corr * RNAVO
+  !
+  IF (lmt_dmsconc(i).LE.1.e-20) lmt_dms(i)=0.0
+  !
+  ENDDO
+  !
+END SUBROUTINE nightingale

LMDZ6/trunk/libf/phylmd/Dust/precuremission.f90

-                      r5245
+                      r5246
 C Subroutine that calculates the emission of aerosols precursors
+      SUBROUTINE precuremission(ftsol,u10m_ec,v10m_ec,
      .                          pctsrf,u_seri,v_seri,paprs,pplay,cdragh,
      .                          cdragm,t_seri,q_seri,tsol,fracso2emis,
      .                          frach2sofso2,bateau,zdz,zalt,
      .                          kminbc,kmaxbc,pdtphys,scale_param_bb,
      .                          scale_param_ind,iregion_ind,iregion_bb,
      .                          nbreg_ind, nbreg_bb,
      .                          lmt_so2ff_l,lmt_so2ff_h,lmt_so2nff,
      .                          lmt_so2ba,lmt_so2bb_l,lmt_so2bb_h,
      .                          lmt_so2volc_cont,lmt_altvolc_cont,
      .                          lmt_so2volc_expl,lmt_altvolc_expl,
      .                          lmt_dmsbio,lmt_h2sbio, lmt_dmsconc,
      .                          lmt_dms,id_prec,id_fine,
      .                                 flux_sparam_ind,flux_sparam_bb,
      .                                 source_tr,flux_tr,tr_seri)
       USE dimphy
       USE indice_sol_mod
       USE infotrac
 !      USE phytracr_spl_mod, ONLY : nbreg_dust, nbreg_ind, nbreg_bb
       IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "chem_spla.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
 c============================= INPUT ===================================
       INTEGER kminbc, kmaxbc
       REAL ftsol(klon,nbsrf)  ! temperature du sol par type
       REAL tsol(klon)         ! temperature du sol moyenne
       REAL t_seri(klon,klev)  ! temperature
       REAL u_seri(klon,klev)  ! vent
       REAL v_seri(klon,klev)  ! vent
       REAL q_seri(klon,klev)  ! vapeur d eau kg/kg
       REAL u10m_ec(klon), v10m_ec(klon)  ! vent a 10 metres
       REAL pctsrf(klon,nbsrf)
       REAL pdtphys  ! pas d'integration pour la physique (seconde)
       REAL paprs(klon,klev+1)  ! pression pour chaque inter-couche (en Pa)
       REAL pplay(klon,klev)  ! pression pour le mileu de chaque couche (en Pa)
       REAL cdragh(klon), cdragm(klon)
       REAL fracso2emis        !--fraction so2 emis en so2
       REAL frach2sofso2       !--fraction h2s from so2
       REAL zdz(klon,klev)
       LOGICAL edgar, bateau
       INTEGER id_prec,id_fine
+c
 c------------------------- Scaling Parameters --------------------------
+c
       INTEGER nbreg_ind, nbreg_bb
       INTEGER iregion_ind(klon)  !Defines regions for SO2, BC & OM
       INTEGER iregion_bb(klon)  !Defines regions for SO2, BC & OM
       REAL scale_param_bb(nbreg_bb)  !Scaling parameter for biomas burning
       REAL scale_param_ind(nbreg_ind) !Scaling parameter for industrial emissions
+c
 c============================= OUTPUT ==================================
+c
       REAL source_tr(klon,nbtr)
       REAL flux_tr(klon,nbtr)
       REAL tr_seri(klon,klev,nbtr) ! traceur
       REAL flux_sparam_ind(klon), flux_sparam_bb(klon)
 c========================= LOCAL VARIABLES =============================
       INTEGER i, k, kkk_cont(klon), kkk_expl(klon)
       REAL zalt(klon,klev), zaltmid(klon,klev)
       REAL zzdz
 c------------------------- SULFUR emissions ----------------------------
       REAL lmt_so2volc_cont(klon)  ! emissions so2 volcan (continuous)
       REAL lmt_altvolc_cont(klon)  ! altitude  so2 volcan (continuous)
       REAL lmt_so2volc_expl(klon)  ! emissions so2 volcan (explosive)
       REAL lmt_altvolc_expl(klon)  ! altitude  so2 volcan (explosive)
       REAL lmt_so2ff_l(klon)       ! emissions so2 fossil fuel (low)
       REAL lmt_so2ff_h(klon)       ! emissions so2 fossil fuel (high)
       REAL lmt_so2nff(klon)        ! emissions so2 non-fossil fuel
       REAL lmt_so2bb_l(klon)       ! emissions de so2 biomass burning (low)
       REAL lmt_so2bb_h(klon)       ! emissions de so2 biomass burning (high)
       REAL lmt_so2ba(klon)         ! emissions de so2 bateau
       REAL lmt_dms(klon)           ! emissions de dms
       REAL lmt_dmsconc(klon)       ! concentration de dms oceanique
       REAL lmt_dmsbio(klon)        ! emissions de dms bio
       REAL lmt_h2sbio(klon)        ! emissions de h2s bio
       EXTERNAL condsurfs, liss, nightingale
 c=========================================================================
 c Modifications introduced by NHL
 c -Variables to save fluxes were introduced
 c -lmt_so2ba was multiplied by fracso2emis in line 117
 c -scale_param_bb was introduced in line 105
+c The last two modifications were errors existing in the original version
 c=========================================================================
 c=========================================================================
 c                        LOW LEVEL EMISSIONS
 c=========================================================================
          CALL nightingale(u_seri, v_seri, u10m_ec, v10m_ec, paprs,
      .                 pplay, cdragh, cdragm, t_seri, q_seri, ftsol,
      .                 tsol, pctsrf, lmt_dmsconc, lmt_dms)
       IF (.not.bateau) THEN
         DO i=1, klon
           lmt_so2ba(i)=0.0
         ENDDO
       ENDIF
       DO i=1, klon
          IF (iregion_ind(i).GT.0) THEN
        IF(id_prec>0) source_tr(i,id_prec)=source_tr(i,id_prec)
      .             + fracso2emis
      .             *scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)*1.e4
      .             +scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)*1.e4
      .                   *frach2sofso2            ! molec/m2/s
+c
       IF(id_fine>0) source_tr(i,id_fine)=
      .                source_tr(i,id_fine)+(1-fracso2emis)
      .                *scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)
      .                *1.e4*masse_ammsulfate/RNAVO  ! g/m2/s
+c
        IF(id_prec>0)   flux_tr(i,id_prec)=flux_tr(i,id_prec) + (
      .               scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
      .                lmt_so2ff_h(i))
      .                *frach2sofso2
      .               +scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
      .                lmt_so2ff_h(i))
      .                *fracso2emis
      .                )*1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+c
       IF(id_fine>0)  flux_tr(i,id_fine)=
      . flux_tr(i,id_fine)+(1-fracso2emis)
      .               *scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
      .                lmt_so2ff_h(i))
      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+c
       flux_sparam_ind(i)=flux_sparam_ind(i)+ (1-fracso2emis)
      .               *scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+
      .                lmt_so2ff_h(i))
      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
          ENDIF
          IF (iregion_bb(i).GT.0) THEN
       IF(id_prec>0) source_tr(i,id_prec)=
      .                  source_tr(i,id_prec) + fracso2emis
      .                 *scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)
      .                   *(1.-pctsrf(i,is_oce))*1.e4
+c
       IF(id_fine>0)     source_tr(i,id_fine)=
      .                   source_tr(i,id_fine)+(1-fracso2emis)
      .                  *scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)*
      .                   (1.-pctsrf(i,is_oce))*1.e4*
      .                   masse_ammsulfate/RNAVO  ! g/m2/s
+c
       IF(id_prec>0)     flux_tr(i,id_prec)=flux_tr(i,id_prec) +
      .               (scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)
      .                 +scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i))
      .                      * (1.-pctsrf(i,is_oce))*fracso2emis
      .                 *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+c
       IF(id_fine>0) flux_tr(i,id_fine)=
      .                flux_tr(i,id_fine)+(1-fracso2emis)
      .               *(scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)
      .                +scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i))
      .                *(1.-pctsrf(i,is_oce))
      .                *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+c
            flux_sparam_bb(i)=
      .                scale_param_bb(iregion_bb(i))*(lmt_so2bb_l(i)+
      .                                        lmt_so2bb_h(i))
      .                      * (1.-pctsrf(i,is_oce))*fracso2emis
      .              *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
            flux_sparam_bb(i)= flux_sparam_bb(i) + (1-fracso2emis) *
      .               (scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)+
      .                scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i))
      .                *(1.-pctsrf(i,is_oce))
      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
          ENDIF
       IF(id_prec>0)   source_tr(i,id_prec)=source_tr(i,id_prec)
      .                 + fracso2emis
      .                 *(lmt_so2ba(i)+lmt_so2nff(i))*1.e4
      .                 +(lmt_h2sbio(i)
      .                   +lmt_dms(i)+lmt_dmsbio(i))*1.e4            ! molec/m2/s
+c
       IF(id_fine>0)   source_tr(i,id_fine)=source_tr(i,id_fine)
      .                +(1-fracso2emis)
      .                *(lmt_so2ba(i)+lmt_so2nff(i))*1.e4*
      .                   masse_ammsulfate/RNAVO  ! g/m2/s
+c
       IF(id_prec>0)   flux_tr(i,id_prec)=flux_tr(i,id_prec)
      .               + (lmt_h2sbio(i)
      .               +lmt_so2volc_cont(i)+lmt_so2volc_expl(i)
      .                 +(lmt_so2ba(i)+lmt_so2nff(i))*fracso2emis
      .                 +lmt_dms(i)+lmt_dmsbio(i) )
      .              *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+c
       IF(id_fine>0)   flux_tr(i,id_fine)=flux_tr(i,id_fine)
      .               +(1-fracso2emis)
      .               *(lmt_so2ba(i) + lmt_so2nff(i))
      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+c
          flux_sparam_ind(i)=flux_sparam_ind(i)+ (1-fracso2emis)
      .               *lmt_so2nff(i)
      .               *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+c
       ENDDO
 c========================================================================
 c                        HIGH LEVEL EMISSIONS
 c========================================================================
 c  Source de SO2 volcaniques
       DO i = 1, klon
         kkk_cont(i)=1
         kkk_expl(i)=1
       ENDDO
       DO k=1, klev-1
       DO i = 1, klon
         zaltmid(i,k)=zalt(i,k)+zdz(i,k)/2.
         IF (zalt(i,k+1).LT.lmt_altvolc_cont(i)) kkk_cont(i)=k+1
         IF (zalt(i,k+1).LT.lmt_altvolc_expl(i)) kkk_expl(i)=k+1
       ENDDO
       ENDDO
       IF(id_prec>0) THEN
       DO i = 1, klon
         tr_seri(i,kkk_cont(i),id_prec)=tr_seri(i,kkk_cont(i),id_prec) +
      .               lmt_so2volc_cont(i)/zdz(i,kkk_cont(i))/100.*pdtphys
         tr_seri(i,kkk_expl(i),id_prec)=tr_seri(i,kkk_expl(i),id_prec) +
      .               lmt_so2volc_expl(i)/zdz(i,kkk_expl(i))/100.*pdtphys
       ENDDO
       ENDIF
+c  Sources hautes de SO2
+c
 c--only GEIA SO2 emissions has high emissions
 c--unit: molec/cm2/s divided by layer height (in cm) multiplied by timestep
+c
       k=2                             !introducing emissions in level 2
       DO i = 1, klon
+c
          IF (iregion_bb(i).GT.0) THEN
       IF(id_prec>0)   tr_seri(i,k,id_prec)=
      .              tr_seri(i,k,id_prec) + fracso2emis
      .              *scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)
      .              /zdz(i,k)/100.*pdtphys
+c
       IF(id_fine>0)     tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)
      .              + (1.-fracso2emis)
      .              *scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)
      .              *masse_ammsulfate/RNAVO/zdz(i,k)/100.*pdtphys   !g/cm3
          ENDIF
          IF (iregion_ind(i).GT.0) THEN
        IF(id_prec>0)  tr_seri(i,k,id_prec)=
      .              tr_seri(i,k,id_prec) + (fracso2emis
      .              *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i)
      .              + frach2sofso2
      .              *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i))
      .              /zdz(i,k)/100.*pdtphys
+c
        IF(id_fine>0)    tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine)
      .               + (1.-fracso2emis)
      .              *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i)
      .              *masse_ammsulfate/RNAVO/zdz(i,k)/100.*pdtphys   !g/cm3
          ENDIF
+c
       ENDDO
+      END
+! Subroutine that calculates the emission of aerosols precursors
+SUBROUTINE precuremission(ftsol,u10m_ec,v10m_ec, &
+        pctsrf,u_seri,v_seri,paprs,pplay,cdragh, &
+        cdragm,t_seri,q_seri,tsol,fracso2emis, &
+        frach2sofso2,bateau,zdz,zalt, &
+        kminbc,kmaxbc,pdtphys,scale_param_bb, &
+        scale_param_ind,iregion_ind,iregion_bb, &
+        nbreg_ind, nbreg_bb, &
+        lmt_so2ff_l,lmt_so2ff_h,lmt_so2nff, &
+        lmt_so2ba,lmt_so2bb_l,lmt_so2bb_h, &
+        lmt_so2volc_cont,lmt_altvolc_cont, &
+        lmt_so2volc_expl,lmt_altvolc_expl, &
+        lmt_dmsbio,lmt_h2sbio, lmt_dmsconc, &
+        lmt_dms,id_prec,id_fine, &
+        flux_sparam_ind,flux_sparam_bb, &
+        source_tr,flux_tr,tr_seri)
+  USE dimphy
+  USE indice_sol_mod
+  USE infotrac
+   ! USE phytracr_spl_mod, ONLY : nbreg_dust, nbreg_ind, nbreg_bb
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "chem_spla.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
+  !============================= INPUT ===================================
+  INTEGER :: kminbc, kmaxbc
+  REAL :: ftsol(klon,nbsrf)  ! temperature du sol par type
+  REAL :: tsol(klon)         ! temperature du sol moyenne
+  REAL :: t_seri(klon,klev)  ! temperature
+  REAL :: u_seri(klon,klev)  ! vent
+  REAL :: v_seri(klon,klev)  ! vent
+  REAL :: q_seri(klon,klev)  ! vapeur d eau kg/kg
+  REAL :: u10m_ec(klon), v10m_ec(klon)  ! vent a 10 metres
+  REAL :: pctsrf(klon,nbsrf)
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+  REAL :: paprs(klon,klev+1)  ! pression pour chaque inter-couche (en Pa)
+  REAL :: pplay(klon,klev)  ! pression pour le mileu de chaque couche (en Pa)
+  REAL :: cdragh(klon), cdragm(klon)
+  REAL :: fracso2emis        !--fraction so2 emis en so2
+  REAL :: frach2sofso2       !--fraction h2s from so2
+  REAL :: zdz(klon,klev)
+  LOGICAL :: edgar, bateau
+  INTEGER :: id_prec,id_fine
+  !
+  !------------------------- Scaling Parameters --------------------------
+  !
+  INTEGER :: nbreg_ind, nbreg_bb
+  INTEGER :: iregion_ind(klon)  !Defines regions for SO2, BC & OM
+  INTEGER :: iregion_bb(klon)  !Defines regions for SO2, BC & OM
+  REAL :: scale_param_bb(nbreg_bb)  !Scaling parameter for biomas burning
+  REAL :: scale_param_ind(nbreg_ind) !Scaling parameter for industrial emissions
+  !
+  !============================= OUTPUT ==================================
+  !
+  REAL :: source_tr(klon,nbtr)
+  REAL :: flux_tr(klon,nbtr)
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: flux_sparam_ind(klon), flux_sparam_bb(klon)
+  !========================= LOCAL VARIABLES =============================
+  INTEGER :: i, k, kkk_cont(klon), kkk_expl(klon)
+  REAL :: zalt(klon,klev), zaltmid(klon,klev)
+  REAL :: zzdz
+  !------------------------- SULFUR emissions ----------------------------
+  REAL :: lmt_so2volc_cont(klon)  ! emissions so2 volcan (continuous)
+  REAL :: lmt_altvolc_cont(klon)  ! altitude  so2 volcan (continuous)
+  REAL :: lmt_so2volc_expl(klon)  ! emissions so2 volcan (explosive)
+  REAL :: lmt_altvolc_expl(klon)  ! altitude  so2 volcan (explosive)
+  REAL :: lmt_so2ff_l(klon)       ! emissions so2 fossil fuel (low)
+  REAL :: lmt_so2ff_h(klon)       ! emissions so2 fossil fuel (high)
+  REAL :: lmt_so2nff(klon)        ! emissions so2 non-fossil fuel
+  REAL :: lmt_so2bb_l(klon)       ! emissions de so2 biomass burning (low)
+  REAL :: lmt_so2bb_h(klon)       ! emissions de so2 biomass burning (high)
+  REAL :: lmt_so2ba(klon)         ! emissions de so2 bateau
+  REAL :: lmt_dms(klon)           ! emissions de dms
+  REAL :: lmt_dmsconc(klon)       ! concentration de dms oceanique
+  REAL :: lmt_dmsbio(klon)        ! emissions de dms bio
+  REAL :: lmt_h2sbio(klon)        ! emissions de h2s bio
+  EXTERNAL condsurfs, liss, nightingale
+  !=========================================================================
+  ! Modifications introduced by NHL
+  ! -Variables to save fluxes were introduced
+  ! -lmt_so2ba was multiplied by fracso2emis in line 117
+  ! -scale_param_bb was introduced in line 105
+  ! The last two modifications were errors existing in the original version
+  !=========================================================================
+  !=========================================================================
+                     ! LOW LEVEL EMISSIONS
+  !=========================================================================
+     CALL nightingale(u_seri, v_seri, u10m_ec, v10m_ec, paprs, &
+           pplay, cdragh, cdragm, t_seri, q_seri, ftsol, &
+           tsol, pctsrf, lmt_dmsconc, lmt_dms)
+  IF (.not.bateau) THEN
+    DO i=1, klon
+      lmt_so2ba(i)=0.0
+    ENDDO
+  ENDIF
+  DO i=1, klon
+     IF (iregion_ind(i).GT.0) THEN
+   IF(id_prec>0) source_tr(i,id_prec)=source_tr(i,id_prec) &
+         + fracso2emis &
+         *scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)*1.e4 &
+         +scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i)*1.e4 &
+         *frach2sofso2            ! molec/m2/s
+  !
+  IF(id_fine>0) source_tr(i,id_fine)= &
+        source_tr(i,id_fine)+(1-fracso2emis) &
+        *scale_param_ind(iregion_ind(i))*lmt_so2ff_l(i) &
+        *1.e4*masse_ammsulfate/RNAVO  ! g/m2/s
+  !
+   IF(id_prec>0)   flux_tr(i,id_prec)=flux_tr(i,id_prec) + ( &
+         scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+ &
+         lmt_so2ff_h(i)) &
+         *frach2sofso2 &
+         +scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+ &
+         lmt_so2ff_h(i)) &
+         *fracso2emis &
+         )*1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+  !
+  IF(id_fine>0)  flux_tr(i,id_fine)= &
+        flux_tr(i,id_fine)+(1-fracso2emis) &
+        *scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+ &
+        lmt_so2ff_h(i)) &
+        *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+  !
+  flux_sparam_ind(i)=flux_sparam_ind(i)+ (1-fracso2emis) &
+        *scale_param_ind(iregion_ind(i))*(lmt_so2ff_l(i)+ &
+        lmt_so2ff_h(i)) &
+        *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+     ENDIF
+     IF (iregion_bb(i).GT.0) THEN
+  IF(id_prec>0) source_tr(i,id_prec)= &
+        source_tr(i,id_prec) + fracso2emis &
+        *scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i) &
+        *(1.-pctsrf(i,is_oce))*1.e4
+  !
+  IF(id_fine>0)     source_tr(i,id_fine)= &
+        source_tr(i,id_fine)+(1-fracso2emis) &
+        *scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)* &
+        (1.-pctsrf(i,is_oce))*1.e4* &
+        masse_ammsulfate/RNAVO  ! g/m2/s
+  !
+  IF(id_prec>0)     flux_tr(i,id_prec)=flux_tr(i,id_prec) + &
+        (scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i) &
+        +scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)) &
+        * (1.-pctsrf(i,is_oce))*fracso2emis &
+        *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+  !
+  IF(id_fine>0) flux_tr(i,id_fine)= &
+        flux_tr(i,id_fine)+(1-fracso2emis) &
+        *(scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i) &
+        +scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)) &
+        *(1.-pctsrf(i,is_oce)) &
+        *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+  !
+       flux_sparam_bb(i)= &
+             scale_param_bb(iregion_bb(i))*(lmt_so2bb_l(i)+ &
+             lmt_so2bb_h(i)) &
+             * (1.-pctsrf(i,is_oce))*fracso2emis &
+             *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+       flux_sparam_bb(i)= flux_sparam_bb(i) + (1-fracso2emis) * &
+             (scale_param_bb(iregion_bb(i))*lmt_so2bb_l(i)+ &
+             scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i)) &
+             *(1.-pctsrf(i,is_oce)) &
+             *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+     ENDIF
+  IF(id_prec>0)   source_tr(i,id_prec)=source_tr(i,id_prec) &
+        + fracso2emis &
+        *(lmt_so2ba(i)+lmt_so2nff(i))*1.e4 &
+        +(lmt_h2sbio(i) &
+        +lmt_dms(i)+lmt_dmsbio(i))*1.e4            ! molec/m2/s
+  !
+  IF(id_fine>0)   source_tr(i,id_fine)=source_tr(i,id_fine) &
+        +(1-fracso2emis) &
+        *(lmt_so2ba(i)+lmt_so2nff(i))*1.e4* &
+        masse_ammsulfate/RNAVO  ! g/m2/s
+  !
+  IF(id_prec>0)   flux_tr(i,id_prec)=flux_tr(i,id_prec) &
+        + (lmt_h2sbio(i) &
+        +lmt_so2volc_cont(i)+lmt_so2volc_expl(i) &
+        +(lmt_so2ba(i)+lmt_so2nff(i))*fracso2emis &
+        +lmt_dms(i)+lmt_dmsbio(i) ) &
+        *1.e4/RNAVO*masse_s*1.e3          ! mgS/m2/s
+  !
+  IF(id_fine>0)   flux_tr(i,id_fine)=flux_tr(i,id_fine) &
+        +(1-fracso2emis) &
+        *(lmt_so2ba(i) + lmt_so2nff(i)) &
+        *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+  !
+     flux_sparam_ind(i)=flux_sparam_ind(i)+ (1-fracso2emis) &
+           *lmt_so2nff(i) &
+           *1.e4/RNAVO*masse_ammsulfate*1.e3    ! mgS/m2/s
+  !
+  ENDDO
+  !========================================================================
+                     ! HIGH LEVEL EMISSIONS
+  !========================================================================
+  !  Source de SO2 volcaniques
+  DO i = 1, klon
+    kkk_cont(i)=1
+    kkk_expl(i)=1
+  ENDDO
+  DO k=1, klev-1
+  DO i = 1, klon
+    zaltmid(i,k)=zalt(i,k)+zdz(i,k)/2.
+    IF (zalt(i,k+1).LT.lmt_altvolc_cont(i)) kkk_cont(i)=k+1
+    IF (zalt(i,k+1).LT.lmt_altvolc_expl(i)) kkk_expl(i)=k+1
+  ENDDO
+  ENDDO
+  IF(id_prec>0) THEN
+  DO i = 1, klon
+    tr_seri(i,kkk_cont(i),id_prec)=tr_seri(i,kkk_cont(i),id_prec) + &
+          lmt_so2volc_cont(i)/zdz(i,kkk_cont(i))/100.*pdtphys
+    tr_seri(i,kkk_expl(i),id_prec)=tr_seri(i,kkk_expl(i),id_prec) + &
+          lmt_so2volc_expl(i)/zdz(i,kkk_expl(i))/100.*pdtphys
+  ENDDO
+  ENDIF
+  !  Sources hautes de SO2
+  !
+  !--only GEIA SO2 emissions has high emissions
+  !--unit: molec/cm2/s divided by layer height (in cm) multiplied by timestep
+  !
+  k=2                             !introducing emissions in level 2
+  DO i = 1, klon
+  !
+     IF (iregion_bb(i).GT.0) THEN
+  IF(id_prec>0)   tr_seri(i,k,id_prec)= &
+        tr_seri(i,k,id_prec) + fracso2emis &
+        *scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i) &
+        /zdz(i,k)/100.*pdtphys
+  !
+  IF(id_fine>0)     tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine) &
+        + (1.-fracso2emis) &
+        *scale_param_bb(iregion_bb(i))*lmt_so2bb_h(i) &
+        *masse_ammsulfate/RNAVO/zdz(i,k)/100.*pdtphys   !g/cm3
+     ENDIF
+     IF (iregion_ind(i).GT.0) THEN
+   IF(id_prec>0)  tr_seri(i,k,id_prec)= &
+         tr_seri(i,k,id_prec) + (fracso2emis &
+         *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i) &
+         + frach2sofso2 &
+         *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i)) &
+         /zdz(i,k)/100.*pdtphys
+  !
+   IF(id_fine>0)    tr_seri(i,k,id_fine)=tr_seri(i,k,id_fine) &
+         + (1.-fracso2emis) &
+         *scale_param_ind(iregion_ind(i))*lmt_so2ff_h(i) &
+         *masse_ammsulfate/RNAVO/zdz(i,k)/100.*pdtphys   !g/cm3
+     ENDIF
+  !
+  ENDDO
+END SUBROUTINE precuremission

LMDZ6/trunk/libf/phylmd/Dust/read_dust.F90

-                      r5245
+                      r5246
       SUBROUTINE read_dust(debutphy, step, nbjour, dust_ec)
       USE dimphy
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "paramet.h"
       INCLUDE "netcdf.inc"
+c
       INTEGER step, nbjour
       LOGICAL debutphy
       real dust_ec(klon)
       real dust_ec_glo(klon_glo)
+c
 c as      real dust_nc(iip1,jjp1)
       real dust_nc_glo(nbp_lon+1,nbp_lat)
       real rcode
       integer ncid1, varid1, ncid2, varid2
+SUBROUTINE read_dust(debutphy, step, nbjour, dust_ec)
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "netcdf.inc"
+  !
+  INTEGER :: step, nbjour
+  LOGICAL :: debutphy
+  real :: dust_ec(klon)
+  real :: dust_ec_glo(klon_glo)
+  !
+  ! as      real dust_nc(iip1,jjp1)
+  real :: dust_nc_glo(nbp_lon+1,nbp_lat)
+  real :: rcode
+  integer :: ncid1, varid1, ncid2, varid2
       save ncid1, varid1, ncid2, varid2
+  save ncid1, varid1, ncid2, varid2
 !$OMP THREADPRIVATE(ncid1, varid1, ncid2, varid2)
       integer start(4),count(4), status
       integer i, j, ig
+c
+  integer :: start(4),count(4), status
+  integer :: i, j, ig
+  !
 !$OMP MASTER
       IF (is_mpi_root .AND. is_omp_root) THEN
       if (debutphy) then
+c
          ncid1=NCOPN('dust.nc',NCNOWRIT,rcode)
          varid1=NCVID(ncid1,'EMISSION',rcode)
+c
       endif
+c
       start(1)=1
       start(2)=1
       start(4)=0
+  IF (is_mpi_root .AND. is_omp_root) THEN
+  if (debutphy) then
+  !
+     ncid1=NCOPN('dust.nc',NCNOWRIT,rcode)
+     varid1=NCVID(ncid1,'EMISSION',rcode)
+  !
+  endif
+  !
+  start(1)=1
+  start(2)=1
+  start(4)=0
 !      count(1)=iip1
       count(1)=nbp_lon+1
 !      count(2)=jjp1
       count(2)=nbp_lat
       count(3)=1
       count(4)=0
+c
       start(3)=step
+c
+   ! count(1)=iip1
+  count(1)=nbp_lon+1
+   ! count(2)=jjp1
+  count(2)=nbp_lat
+  count(3)=1
+  count(4)=0
+  !
+  start(3)=step
+  !
 #ifdef NC_DOUBLE
 !      status=NF_GET_VARA_DOUBLE(ncid1,varid1,start,count,dust_nc)
       status=NF_GET_VARA_DOUBLE(ncid1,varid1,start,count,dust_nc_glo)
+   ! status=NF_GET_VARA_DOUBLE(ncid1,varid1,start,count,dust_nc)
+  status=NF_GET_VARA_DOUBLE(ncid1,varid1,start,count,dust_nc_glo)
 #else
 !      status=NF_GET_VARA_REAL(ncid1,varid1,start,count,dust_nc)
       status=NF_GET_VARA_REAL(ncid1,varid1,start,count,dust_nc_glo)
+   ! status=NF_GET_VARA_REAL(ncid1,varid1,start,count,dust_nc)
+  status=NF_GET_VARA_REAL(ncid1,varid1,start,count,dust_nc_glo)
 #endif
+c
 !      call correctbid(iim,jjp1,dust_nc)
       call correctbid(nbp_lon,nbp_lat,dust_nc_glo)
+c
 c--upside down + physical grid
+c
+c--OB=change jjp1 to 1 here ;
 c----AS: OB's change is needed if lats N to S (90 to -90) in dust.nc
 !      dust_ec(1)=MAX(dust_nc(1,jjp1),0.0)
       dust_ec_glo(1)=MAX(dust_nc_glo(1,nbp_lat),0.0)
       ig=2
 !      DO j=2,jjm
       DO j=2,nbp_lat-1
 !         DO i = 1, iim
          DO i = 1, nbp_lon
 c--OB=change jjp1+1-j to j here
 !           dust_ec(ig)=MAX(dust_nc(i,jjp1+1-j),0.0)
            dust_ec_glo(ig)=MAX(dust_nc_glo(i,nbp_lat+1-j),0.0)
            ig=ig+1
          ENDDO
       ENDDO
 c--OB=change second 1 to jjp1 here
       dust_ec_glo(ig)=MAX(dust_nc_glo(1,1),0.0)
 !      end if master
       ENDIF
+  !
+  !  call correctbid(iim,jjp1,dust_nc)
+  call correctbid(nbp_lon,nbp_lat,dust_nc_glo)
+  !
+  !--upside down + physical grid
+  !
+  !--OB=change jjp1 to 1 here ;
+  !----AS: OB's change is needed if lats N to S (90 to -90) in dust.nc
+  !  dust_ec(1)=MAX(dust_nc(1,jjp1),0.0)
+  dust_ec_glo(1)=MAX(dust_nc_glo(1,nbp_lat),0.0)
+  ig=2
+   ! DO j=2,jjm
+  DO j=2,nbp_lat-1
+      ! DO i = 1, iim
+     DO i = 1, nbp_lon
+  !--OB=change jjp1+1-j to j here
+        ! dust_ec(ig)=MAX(dust_nc(i,jjp1+1-j),0.0)
+       dust_ec_glo(ig)=MAX(dust_nc_glo(i,nbp_lat+1-j),0.0)
+       ig=ig+1
+     ENDDO
+  ENDDO
+  !--OB=change second 1 to jjp1 here
+  dust_ec_glo(ig)=MAX(dust_nc_glo(1,1),0.0)
+   ! end if master
+  ENDIF
 !$OMP END MASTER
 !$OMP BARRIER
       CALL scatter(dust_ec_glo,dust_ec)
+c
       RETURN
+      END
+  CALL scatter(dust_ec_glo,dust_ec)
+  !
+  RETURN
+END SUBROUTINE read_dust

LMDZ6/trunk/libf/phylmd/Dust/read_newemissions.f90

-                      r5245
+                      r5246
 C Routine to read the emissions of the different species
+C
+      subroutine read_newemissions(julien, jH_emi ,edgar, flag_dms,
      I                             debutphy,
      I                             pdtphys,lafinphy, nbjour, pctsrf,
      I                             t_seri, xlat, xlon,
      I                             pmflxr, pmflxs, prfl, psfl,
      O                             u10m_ec, v10m_ec, dust_ec,
      O                             lmt_sea_salt, lmt_so2ff_l,
      O                             lmt_so2ff_h, lmt_so2nff, lmt_so2ba,
      O                             lmt_so2bb_l, lmt_so2bb_h,
      O                             lmt_so2volc_cont, lmt_altvolc_cont,
      O                             lmt_so2volc_expl, lmt_altvolc_expl,
      O                             lmt_dmsbio, lmt_h2sbio, lmt_dmsconc,
      O                             lmt_bcff, lmt_bcnff, lmt_bcbb_l,
      O                             lmt_bcbb_h, lmt_bcba, lmt_omff,
      O                             lmt_omnff, lmt_ombb_l, lmt_ombb_h,
      O                             lmt_omnat, lmt_omba)
       USE dimphy
       USE indice_sol_mod
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
       IMPLICIT NONE
       INCLUDE "dimensions.h"
+c      INCLUDE 'dimphy.h'
       INCLUDE 'paramet.h'
       INCLUDE 'chem.h'
       INCLUDE 'chem_spla.h'
 c      INCLUDE 'indicesol.h'
       logical debutphy, lafinphy, edgar
       INTEGER test_vent, test_day, step_vent, flag_dms, nbjour
       INTEGER julien, i, iday
       SAVE step_vent, test_vent, test_day, iday
+! Routine to read the emissions of the different species
+!
+subroutine read_newemissions(julien, jH_emi ,edgar, flag_dms, &
+        debutphy, &
+        pdtphys,lafinphy, nbjour, pctsrf, &
+        t_seri, xlat, xlon, &
+        pmflxr, pmflxs, prfl, psfl, &
+        u10m_ec, v10m_ec, dust_ec, &
+        lmt_sea_salt, lmt_so2ff_l, &
+        lmt_so2ff_h, lmt_so2nff, lmt_so2ba, &
+        lmt_so2bb_l, lmt_so2bb_h, &
+        lmt_so2volc_cont, lmt_altvolc_cont, &
+        lmt_so2volc_expl, lmt_altvolc_expl, &
+        lmt_dmsbio, lmt_h2sbio, lmt_dmsconc, &
+        lmt_bcff, lmt_bcnff, lmt_bcbb_l, &
+        lmt_bcbb_h, lmt_bcba, lmt_omff, &
+        lmt_omnff, lmt_ombb_l, lmt_ombb_h, &
+        lmt_omnat, lmt_omba)
+  USE dimphy
+  USE indice_sol_mod
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+   ! INCLUDE 'dimphy.h'
+  INCLUDE 'paramet.h'
+  INCLUDE 'chem.h'
+  INCLUDE 'chem_spla.h'
+   ! INCLUDE 'indicesol.h'
+  logical :: debutphy, lafinphy, edgar
+  INTEGER :: test_vent, test_day, step_vent, flag_dms, nbjour
+  INTEGER :: julien, i, iday
+  SAVE step_vent, test_vent, test_day, iday
 !$OMP THREADPRIVATE(step_vent, test_vent, test_day, iday)
       REAL pct_ocean(klon), pctsrf(klon,nbsrf)
       REAL pdtphys  ! pas d'integration pour la physique (seconde)
       REAL t_seri(klon,klev)  ! temperature
       REAL xlat(klon)       ! latitudes pour chaque point
       REAL xlon(klon)       ! longitudes pour chaque point
+c
 c   Emissions:
 c   ---------
+c
 c---------------------------- SEA SALT & DUST emissions ------------------------
       REAL lmt_sea_salt(klon,ss_bins) !Sea salt 0.03-8.0 um !NOT SAVED OK
       REAL clyfac, avgdryrate, drying
 c je      REAL u10m_ec1(klon), v10m_ec1(klon), dust_ec1(klon)
 c je      REAL u10m_ec2(klon), v10m_ec2(klon), dust_ec2(klon)
       REAL, SAVE, ALLOCATABLE :: u10m_ec1(:), v10m_ec1(:), dust_ec1(:)
       REAL, SAVE, ALLOCATABLE :: u10m_ec2(:), v10m_ec2(:), dust_ec2(:)
+  REAL :: pct_ocean(klon), pctsrf(klon,nbsrf)
+  REAL :: pdtphys  ! pas d'integration pour la physique (seconde)
+  REAL :: t_seri(klon,klev)  ! temperature
+  REAL :: xlat(klon)       ! latitudes pour chaque point
+  REAL :: xlon(klon)       ! longitudes pour chaque point
+  !
+  !   Emissions:
+  !   ---------
+  !
+  !---------------------------- SEA SALT & DUST emissions ------------------------
+  REAL :: lmt_sea_salt(klon,ss_bins) !Sea salt 0.03-8.0 um !NOT SAVED OK
+  REAL :: clyfac, avgdryrate, drying
+  ! je      REAL u10m_ec1(klon), v10m_ec1(klon), dust_ec1(klon)
+  ! je      REAL u10m_ec2(klon), v10m_ec2(klon), dust_ec2(klon)
+  REAL, SAVE, ALLOCATABLE :: u10m_ec1(:), v10m_ec1(:), dust_ec1(:)
+  REAL, SAVE, ALLOCATABLE :: u10m_ec2(:), v10m_ec2(:), dust_ec2(:)
 !$OMP THREADPRIVATE(u10m_ec1, v10m_ec1, dust_ec1)
 !$OMP THREADPRIVATE(u10m_ec2, v10m_ec2, dust_ec2)
 c as      REAL u10m_nc(iip1,jjp1), v10m_nc(iip1,jjp1)
       REAL u10m_ec(klon), v10m_ec(klon), dust_ec(klon)
 c      REAL cly(klon), wth(klon), zprecipinsoil(klon)
       REAL, SAVE, ALLOCATABLE :: cly(:), wth(:), zprecipinsoil(:)
       REAL :: cly_glo(klon_glo), wth_glo(klon_glo)
       REAL :: zprecipinsoil_glo(klon_glo)
+  ! as      REAL u10m_nc(iip1,jjp1), v10m_nc(iip1,jjp1)
+  REAL :: u10m_ec(klon), v10m_ec(klon), dust_ec(klon)
+  !      REAL cly(klon), wth(klon), zprecipinsoil(klon)
+  REAL, SAVE, ALLOCATABLE :: cly(:), wth(:), zprecipinsoil(:)
+  REAL :: cly_glo(klon_glo), wth_glo(klon_glo)
+  REAL :: zprecipinsoil_glo(klon_glo)
 !$OMP THREADPRIVATE(cly,wth,zprecipinsoil)
 c je     SAVE u10m_ec2, v10m_ec2, dust_ec2
 c je      SAVE u10m_ec1, v10m_ec1, dust_ec1   ! Added on titane
 c je      SAVE cly, wth, zprecipinsoil        ! Added on titane
 !     SAVE cly, wth, zprecipinsoil, u10m_ec2, v10m_ec2, dust_ec2
 c------------------------- BLACK CARBON emissions ----------------------
       REAL lmt_bcff(klon)       ! emissions de BC fossil fuels
       REAL lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
       REAL lmt_bcbb_l(klon)     ! emissions de BC biomass basses
       REAL lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
       REAL lmt_bcba(klon)       ! emissions de BC bateau
 c------------------------ ORGANIC MATTER emissions ---------------------
       REAL lmt_omff(klon)     ! emissions de OM fossil fuels
       REAL lmt_omnff(klon)    ! emissions de OM non-fossil fuels
       REAL lmt_ombb_l(klon)   ! emissions de OM biomass basses
       REAL lmt_ombb_h(klon)   ! emissions de OM biomass hautes
       REAL lmt_omnat(klon)    ! emissions de OM Natural
       REAL lmt_omba(klon)     ! emissions de OM bateau
 c------------------------- SULFUR emissions ----------------------------
       REAL lmt_so2ff_l(klon)       ! emissions so2 fossil fuels (low)
       REAL lmt_so2ff_h(klon)       ! emissions so2 fossil fuels (high)
       REAL lmt_so2nff(klon)        ! emissions so2 non-fossil fuels
       REAL lmt_so2bb_l(klon)       ! emissions de so2 biomass burning basse
       REAL lmt_so2bb_h(klon)       ! emissions de so2 biomass burning hautes
       REAL lmt_so2ba(klon)         ! emissions de so2 bateau
       REAL lmt_so2volc_cont(klon)  ! emissions so2 volcan continuous
       REAL lmt_altvolc_cont(klon)  ! altitude  so2 volcan continuous
       REAL lmt_so2volc_expl(klon)  ! emissions so2 volcan explosive
       REAL lmt_altvolc_expl(klon)  ! altitude  so2 volcan explosive
       REAL lmt_dmsconc(klon)       ! concentration de dms oceanique
       REAL lmt_dmsbio(klon)        ! emissions de dms bio
       REAL lmt_h2sbio(klon)        ! emissions de h2s bio
       REAL,SAVE,ALLOCATABLE ::  lmt_dms(:)           ! emissions de dms
+  ! je     SAVE u10m_ec2, v10m_ec2, dust_ec2
+  ! je      SAVE u10m_ec1, v10m_ec1, dust_ec1   ! Added on titane
+  ! je      SAVE cly, wth, zprecipinsoil        ! Added on titane
+  ! SAVE cly, wth, zprecipinsoil, u10m_ec2, v10m_ec2, dust_ec2
+  !------------------------- BLACK CARBON emissions ----------------------
+  REAL :: lmt_bcff(klon)       ! emissions de BC fossil fuels
+  REAL :: lmt_bcnff(klon)      ! emissions de BC non-fossil fuels
+  REAL :: lmt_bcbb_l(klon)     ! emissions de BC biomass basses
+  REAL :: lmt_bcbb_h(klon)     ! emissions de BC biomass hautes
+  REAL :: lmt_bcba(klon)       ! emissions de BC bateau
+  !------------------------ ORGANIC MATTER emissions ---------------------
+  REAL :: lmt_omff(klon)     ! emissions de OM fossil fuels
+  REAL :: lmt_omnff(klon)    ! emissions de OM non-fossil fuels
+  REAL :: lmt_ombb_l(klon)   ! emissions de OM biomass basses
+  REAL :: lmt_ombb_h(klon)   ! emissions de OM biomass hautes
+  REAL :: lmt_omnat(klon)    ! emissions de OM Natural
+  REAL :: lmt_omba(klon)     ! emissions de OM bateau
+  !------------------------- SULFUR emissions ----------------------------
+  REAL :: lmt_so2ff_l(klon)       ! emissions so2 fossil fuels (low)
+  REAL :: lmt_so2ff_h(klon)       ! emissions so2 fossil fuels (high)
+  REAL :: lmt_so2nff(klon)        ! emissions so2 non-fossil fuels
+  REAL :: lmt_so2bb_l(klon)       ! emissions de so2 biomass burning basse
+  REAL :: lmt_so2bb_h(klon)       ! emissions de so2 biomass burning hautes
+  REAL :: lmt_so2ba(klon)         ! emissions de so2 bateau
+  REAL :: lmt_so2volc_cont(klon)  ! emissions so2 volcan continuous
+  REAL :: lmt_altvolc_cont(klon)  ! altitude  so2 volcan continuous
+  REAL :: lmt_so2volc_expl(klon)  ! emissions so2 volcan explosive
+  REAL :: lmt_altvolc_expl(klon)  ! altitude  so2 volcan explosive
+  REAL :: lmt_dmsconc(klon)       ! concentration de dms oceanique
+  REAL :: lmt_dmsbio(klon)        ! emissions de dms bio
+  REAL :: lmt_h2sbio(klon)        ! emissions de h2s bio
+  REAL,SAVE,ALLOCATABLE ::  lmt_dms(:)           ! emissions de dms
 !$OMP THREADPRIVATE(lmt_dms)
+c
 c  Lessivage
 c  ---------
+c
       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) !--convection
       REAL prfl(klon,klev+1),   psfl(klon,klev+1)   !--large-scale
 !      REAL pmflxr(klon,klev), pmflxs(klon,klev) !--convection
 !      REAL prfl(klon,klev),   psfl(klon,klev)   !--large-scale
+c
 c  Variable interne
 c  ----------------
+c
       INTEGER icount
       REAL tau_1, tau_2
       REAL max_flux, min_flux
       INTRINSIC MIN, MAX
+c
 c JE: Changes due to new pdtphys in new physics.
+c      REAL windintime ! time in hours of the wind input files resolution
+c      REAL dayemintime ! time in hours of the other emissions input files resolution
       REAL jH_init ! shift in the hour (count as days) respecto to
 !                  ! realhour = (pdtphys*i)/3600/24 -days_elapsed
       REAL jH_emi,jH_vent,jH_day
       SAVE jH_init,jH_vent,jH_day
+  !
+  !  Lessivage
+  !  ---------
+  !
+  REAL :: pmflxr(klon,klev+1), pmflxs(klon,klev+1) !--convection
+  REAL :: prfl(klon,klev+1),   psfl(klon,klev+1)   !--large-scale
+   ! REAL pmflxr(klon,klev), pmflxs(klon,klev) !--convection
+   ! REAL prfl(klon,klev),   psfl(klon,klev)   !--large-scale
+  !
+  !  Variable interne
+  !  ----------------
+  !
+  INTEGER :: icount
+  REAL :: tau_1, tau_2
+  REAL :: max_flux, min_flux
+  INTRINSIC MIN, MAX
+  !
+  ! JE: Changes due to new pdtphys in new physics.
+  !  REAL windintime ! time in hours of the wind input files resolution
+  !  REAL dayemintime ! time in hours of the other emissions input files resolution
+  REAL :: jH_init ! shift in the hour (count as days) respecto to
+               ! ! realhour = (pdtphys*i)/3600/24 -days_elapsed
+  REAL :: jH_emi,jH_vent,jH_day
+  SAVE jH_init,jH_vent,jH_day
 !$OMP THREADPRIVATE(jH_init,jH_vent,jH_day)
       REAL,PARAMETER :: vent_resol = 6. ! resolution of winds in hours
       REAL,PARAMETER :: day_resol = 24. ! resolution of daily emmis. in hours
 !      INTEGER   test_day1
 !      SAVE test_day1
 !      REAL tau_1j,tau_2j
 c je
 c allocate if necessary
+c
       IF (.NOT. ALLOCATED(u10m_ec1)) ALLOCATE(u10m_ec1(klon))
       IF (.NOT. ALLOCATED(v10m_ec1)) ALLOCATE(v10m_ec1(klon))
       IF (.NOT. ALLOCATED(dust_ec1)) ALLOCATE(dust_ec1(klon))
       IF (.NOT. ALLOCATED(u10m_ec2)) ALLOCATE(u10m_ec2(klon))
       IF (.NOT. ALLOCATED(v10m_ec2)) ALLOCATE(v10m_ec2(klon))
       IF (.NOT. ALLOCATED(dust_ec2)) ALLOCATE(dust_ec2(klon))
       IF (.NOT. ALLOCATED(cly)) ALLOCATE(cly(klon))
       IF (.NOT. ALLOCATED(wth)) ALLOCATE(wth(klon))
       IF (.NOT. ALLOCATED(zprecipinsoil)) ALLOCATE(zprecipinsoil(klon))
       IF (.NOT. ALLOCATED(lmt_dms)) ALLOCATE(lmt_dms(klon))
 c end je nov2013
+c
 C***********************************************************************
 C DUST EMISSIONS
 C***********************************************************************
+c
       IF (debutphy) THEN
 C---Fields are read only at the beginning of the period
 c--reading wind and dust
         iday=julien
         step_vent=1
         test_vent=0
         test_day=0
         CALL read_vent(.true.,step_vent,nbjour,u10m_ec2,v10m_ec2)
         print *,'Read (debut) dust emissions: step_vent,julien,nbjour',
      .                                   step_vent,julien,nbjour
         CALL read_dust(.true.,step_vent,nbjour,dust_ec2)
 C Threshold velocity map
+  REAL,PARAMETER :: vent_resol = 6. ! resolution of winds in hours
+  REAL,PARAMETER :: day_resol = 24. ! resolution of daily emmis. in hours
+   ! INTEGER   test_day1
+   ! SAVE test_day1
+   ! REAL tau_1j,tau_2j
+  ! je
+  ! allocate if necessary
+  !
+  IF (.NOT. ALLOCATED(u10m_ec1)) ALLOCATE(u10m_ec1(klon))
+  IF (.NOT. ALLOCATED(v10m_ec1)) ALLOCATE(v10m_ec1(klon))
+  IF (.NOT. ALLOCATED(dust_ec1)) ALLOCATE(dust_ec1(klon))
+  IF (.NOT. ALLOCATED(u10m_ec2)) ALLOCATE(u10m_ec2(klon))
+  IF (.NOT. ALLOCATED(v10m_ec2)) ALLOCATE(v10m_ec2(klon))
+  IF (.NOT. ALLOCATED(dust_ec2)) ALLOCATE(dust_ec2(klon))
+  IF (.NOT. ALLOCATED(cly)) ALLOCATE(cly(klon))
+  IF (.NOT. ALLOCATED(wth)) ALLOCATE(wth(klon))
+  IF (.NOT. ALLOCATED(zprecipinsoil)) ALLOCATE(zprecipinsoil(klon))
+  IF (.NOT. ALLOCATED(lmt_dms)) ALLOCATE(lmt_dms(klon))
+  ! end je nov2013
+  !
+  !***********************************************************************
+  ! DUST EMISSIONS
+  !***********************************************************************
+  !
+  IF (debutphy) THEN
+  !---Fields are read only at the beginning of the period
+  !--reading wind and dust
+    iday=julien
+    step_vent=1
+    test_vent=0
+    test_day=0
+    CALL read_vent(.true.,step_vent,nbjour,u10m_ec2,v10m_ec2)
+    print *,'Read (debut) dust emissions: step_vent,julien,nbjour', &
+          step_vent,julien,nbjour
+    CALL read_dust(.true.,step_vent,nbjour,dust_ec2)
+  ! Threshold velocity map
 !$OMP MASTER
        IF (is_mpi_root .AND. is_omp_root) THEN
         zprecipinsoil_glo(:)=0.0
         OPEN(51,file='wth.dat',status='unknown',form='formatted')
         READ(51,'(G18.10)') (wth_glo(i),i=1,klon_glo)
         CLOSE(51)
 c Clay content
         OPEN(52,file='cly.dat',status='unknown',form='formatted')
         READ(52,'(G18.10)') (cly_glo(i),i=1,klon_glo)
         CLOSE(52)
         OPEN(53,file='precipinsoil.dat',
      .        status='old',form='formatted',err=999)
         READ(53,'(G18.10)') (zprecipinsoil_glo(i),i=1,klon_glo)
         PRINT *,'lecture precipinsoil.dat'
     CONTINUE
         CLOSE(53)
        ENDIF
+   IF (is_mpi_root .AND. is_omp_root) THEN
+    zprecipinsoil_glo(:)=0.0
+    OPEN(51,file='wth.dat',status='unknown',form='formatted')
+    READ(51,'(G18.10)') (wth_glo(i),i=1,klon_glo)
+    CLOSE(51)
+  ! Clay content
+    OPEN(52,file='cly.dat',status='unknown',form='formatted')
+    READ(52,'(G18.10)') (cly_glo(i),i=1,klon_glo)
+    CLOSE(52)
+    OPEN(53,file='precipinsoil.dat', &
+          status='old',form='formatted',err=999)
+    READ(53,'(G18.10)') (zprecipinsoil_glo(i),i=1,klon_glo)
+    PRINT *,'lecture precipinsoil.dat'
+   CONTINUE
+    CLOSE(53)
+   ENDIF
 !$OMP END MASTER
 !$OMP BARRIER
        call scatter(wth_glo,wth)
        call scatter(cly_glo,cly)
        call scatter(zprecipinsoil_glo,zprecipinsoil)
 !JE20140908<<        GOTO 1000
 !        DO i=1, klon
 !          zprecipinsoil(i)=0.0
 !        ENDDO
 ! 1000   CLOSE(53)
 !JE20140908>>
         jH_init=jH_emi
         jH_vent=jH_emi
         jH_day=jH_emi
 !        test_day1=0
 !JE end
+c
       ENDIF !--- debutphy
       print *,'READ_EMISSION: test_vent & test_day = ',test_vent,
      +                                                 test_day
       IF (test_vent.EQ.0) THEN    !--on lit toutes les 6 h
         CALL SCOPY(klon, u10m_ec2, 1, u10m_ec1, 1)
         CALL SCOPY(klon, v10m_ec2, 1, v10m_ec1, 1)
         CALL SCOPY(klon, dust_ec2, 1, dust_ec1, 1)
         step_vent=step_vent+1
         !PRINT *,'step_vent=', step_vent
         CALL read_vent(.false.,step_vent,nbjour,u10m_ec2,v10m_ec2)
         print *,'Reading dust emissions: step_vent, julien, nbjour ',
      .                                   step_vent, julien, nbjour
         !print *,'test_vent, julien = ',test_vent, julien
         CALL read_dust(.false.,step_vent,nbjour,dust_ec2)
       ENDIF !--test_vent
 c     ubicacion original
 c      test_vent=test_vent+1
 c      IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
 !JE      tau_2=FLOAT(test_vent)/12.
 !JE      tau_1=1.-tau_2
       tau_2=(jH_vent-jH_init)*24./(vent_resol)
       tau_1=1.-tau_2
 !      print*,'JEdec jHv,JHi,ventres',jH_vent,jH_init,vent_resol
 !      print*,'JEdec tau2,tau1',tau_2,tau_1
 !      print*,'JEdec step_vent',step_vent
       DO i=1, klon
 !      PRINT*,'JE tau_2,tau_2j',tau_2,tau_2j
         u10m_ec(i)=tau_1*u10m_ec1(i)+tau_2*u10m_ec2(i)
         v10m_ec(i)=tau_1*v10m_ec1(i)+tau_2*v10m_ec2(i)
         dust_ec(i)=tau_1*dust_ec1(i)+tau_2*dust_ec2(i)
       ENDDO
+c
 cJE      IF (test_vent.EQ.(6*2)) THEN
 cJE        PRINT *,'6 hrs interval reached'
 cJE        print *,'day in read_emission, test_vent = ',julien, test_vent
 cJE      ENDIF
 cJE
 !JE      test_vent=test_vent+1
 !JE      IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
+c JE
       jH_vent=jH_vent+pdtphys/(24.*3600.)
       test_vent=test_vent+1
       IF (jH_vent.GT.(vent_resol)/24.) THEN
           test_vent=0
           jH_vent=jH_init
       ENDIF
 !      PRINT*,'JE test_vent,test_vent1,jH_vent ', test_vent,test_vent1
 !     .     ,jH_vent
 c endJEi
+c
       avgdryrate=300./365.*pdtphys/86400.
+c
       DO i=1, klon
+c
         IF (cly(i).LT.9990..AND.wth(i).LT.9990.) THEN
           zprecipinsoil(i)=zprecipinsoil(i) +
      .           (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
+c
           clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
           drying=avgdryrate*exp(0.03905491*
      .                    exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
           zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
         ENDIF
 !        zprecipinsoil(i)=0.0 ! Temporarely introduced to reproduce obelix result
       ENDDO
 !      print *,'cly = ',sum(cly),maxval(cly),minval(cly)
 !      print *,'wth = ',sum(wth),maxval(wth),minval(wth)
 !      print *,'t_seri = ',sum(t_seri),maxval(t_seri),minval(t_seri)
 !      print *,'precipinsoil = ',sum(zprecipinsoil),maxval(zprecipinsoil)
 !     .                      ,minval(zprecipinsoil)
       icount=0
       DO i=1, klon
         IF (cly(i).GE.9990..OR.wth(i).GE.9990..OR.
      .     t_seri(i,1).LE.273.15.OR.zprecipinsoil(i).GT.1.e-8) THEN
              dust_ec(i)=0.0 ! commented out for test dustemtest
 !             print *,'Dust emissions surpressed at grid = ',i
 !             icount=icount+1
         ENDIF
       ENDDO
+c
       print *,'Total N of grids with surpressed emission = ',icount
       print *,'dust_ec = ',SUM(dust_ec),MINVAL(dust_ec),
      .                                  MAXVAL(dust_ec)
 cnhl Transitory scaling of desert dust emissions
 cnhl      DO i=1, klon
 cnhl         dust_ec(i)=dust_ec(i)/2.
+cnhl      ENDDO
 C-saving precipitation field to be read in next simulation
       IF (lafinphy) THEN
+c
         CALL gather(zprecipinsoil,zprecipinsoil_glo)
+   call scatter(wth_glo,wth)
+   call scatter(cly_glo,cly)
+   call scatter(zprecipinsoil_glo,zprecipinsoil)
+  !JE20140908<<        GOTO 1000
+     ! DO i=1, klon
+     !   zprecipinsoil(i)=0.0
+     ! ENDDO
+  ! 1000   CLOSE(53)
+  !JE20140908>>
+    jH_init=jH_emi
+    jH_vent=jH_emi
+    jH_day=jH_emi
+     ! test_day1=0
+  !JE end
+  !
+  ENDIF !--- debutphy
+  print *,'READ_EMISSION: test_vent & test_day = ',test_vent, &
+        test_day
+  IF (test_vent.EQ.0) THEN    !--on lit toutes les 6 h
+    CALL SCOPY(klon, u10m_ec2, 1, u10m_ec1, 1)
+    CALL SCOPY(klon, v10m_ec2, 1, v10m_ec1, 1)
+    CALL SCOPY(klon, dust_ec2, 1, dust_ec1, 1)
+    step_vent=step_vent+1
+    ! !PRINT *,'step_vent=', step_vent
+    CALL read_vent(.false.,step_vent,nbjour,u10m_ec2,v10m_ec2)
+    print *,'Reading dust emissions: step_vent, julien, nbjour ', &
+          step_vent, julien, nbjour
+    ! !print *,'test_vent, julien = ',test_vent, julien
+    CALL read_dust(.false.,step_vent,nbjour,dust_ec2)
+  ENDIF !--test_vent
+  ! ubicacion original
+  !  test_vent=test_vent+1
+  !  IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
+  !JE      tau_2=FLOAT(test_vent)/12.
+  !JE      tau_1=1.-tau_2
+  tau_2=(jH_vent-jH_init)*24./(vent_resol)
+  tau_1=1.-tau_2
+   ! print*,'JEdec jHv,JHi,ventres',jH_vent,jH_init,vent_resol
+   ! print*,'JEdec tau2,tau1',tau_2,tau_1
+   ! print*,'JEdec step_vent',step_vent
+  DO i=1, klon
+   ! PRINT*,'JE tau_2,tau_2j',tau_2,tau_2j
+    u10m_ec(i)=tau_1*u10m_ec1(i)+tau_2*u10m_ec2(i)
+    v10m_ec(i)=tau_1*v10m_ec1(i)+tau_2*v10m_ec2(i)
+    dust_ec(i)=tau_1*dust_ec1(i)+tau_2*dust_ec2(i)
+  ENDDO
+  !
+  !JE      IF (test_vent.EQ.(6*2)) THEN
+  !JE        PRINT *,'6 hrs interval reached'
+  !JE        print *,'day in read_emission, test_vent = ',julien, test_vent
+  !JE      ENDIF
+  !JE
+  !JE      test_vent=test_vent+1
+  !JE      IF (test_vent.EQ.(6*2)) test_vent=0 !on remet a zero ttes les 6 h
+  ! JE
+  jH_vent=jH_vent+pdtphys/(24.*3600.)
+  test_vent=test_vent+1
+  IF (jH_vent.GT.(vent_resol)/24.) THEN
+      test_vent=0
+      jH_vent=jH_init
+  ENDIF
+   ! PRINT*,'JE test_vent,test_vent1,jH_vent ', test_vent,test_vent1
+  ! .     ,jH_vent
+  ! endJEi
+  !
+  avgdryrate=300./365.*pdtphys/86400.
+  !
+  DO i=1, klon
+  !
+    IF (cly(i).LT.9990..AND.wth(i).LT.9990.) THEN
+      zprecipinsoil(i)=zprecipinsoil(i) + &
+            (pmflxr(i,1)+pmflxs(i,1)+prfl(i,1)+psfl(i,1))*pdtphys
+  !
+      clyfac=MIN(16., cly(i)*0.4+8.) ![mm] max amount of water hold in top soil
+      drying=avgdryrate*exp(0.03905491* &
+            exp(0.17446*(t_seri(i,1)-273.15))) ! [mm]
+      zprecipinsoil(i)=min(max(0.,zprecipinsoil(i)-drying),clyfac) ! [mm]
+    ENDIF
+     ! zprecipinsoil(i)=0.0 ! Temporarely introduced to reproduce obelix result
+  ENDDO
+   ! print *,'cly = ',sum(cly),maxval(cly),minval(cly)
+   ! print *,'wth = ',sum(wth),maxval(wth),minval(wth)
+   ! print *,'t_seri = ',sum(t_seri),maxval(t_seri),minval(t_seri)
+   ! print *,'precipinsoil = ',sum(zprecipinsoil),maxval(zprecipinsoil)
+  ! .                      ,minval(zprecipinsoil)
+  icount=0
+  DO i=1, klon
+    IF (cly(i).GE.9990..OR.wth(i).GE.9990..OR. &
+          t_seri(i,1).LE.273.15.OR.zprecipinsoil(i).GT.1.e-8) THEN
+         dust_ec(i)=0.0 ! commented out for test dustemtest
+          ! print *,'Dust emissions surpressed at grid = ',i
+          ! icount=icount+1
+    ENDIF
+  ENDDO
+  !
+  print *,'Total N of grids with surpressed emission = ',icount
+  print *,'dust_ec = ',SUM(dust_ec),MINVAL(dust_ec), &
+        MAXVAL(dust_ec)
+  !nhl Transitory scaling of desert dust emissions
+  !nhl      DO i=1, klon
+  !nhl         dust_ec(i)=dust_ec(i)/2.
+  !nhl      ENDDO
+  !-saving precipitation field to be read in next simulation
+  IF (lafinphy) THEN
+  !
+    CALL gather(zprecipinsoil,zprecipinsoil_glo)
 !$OMP MASTER
         IF (is_mpi_root .AND. is_omp_root) THEN
         OPEN(53,file='newprecipinsoil.dat',
      .          status='unknown',form='formatted')
         WRITE(53,'(G18.10)') (zprecipinsoil_glo(i),i=1,klon_glo)
         CLOSE(53)
         ENDIF
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    OPEN(53,file='newprecipinsoil.dat', &
+          status='unknown',form='formatted')
+    WRITE(53,'(G18.10)') (zprecipinsoil_glo(i),i=1,klon_glo)
+    CLOSE(53)
+    ENDIF
 !$OMP END MASTER
 !$OMP BARRIER
+c
       ENDIF
+c
 C***********************************************************************
 C SEA SALT EMISSIONS
 C***********************************************************************
+c
       DO i=1,klon
         pct_ocean(i)=pctsrf(i,is_oce)
       ENDDO
       print *,'IS_OCE = ',is_oce
       CALL seasalt(v10m_ec, u10m_ec, pct_ocean, lmt_sea_salt) !mgSeaSalt/cm2/s
 !      print *,'SUM, MAX & MIN Sea Salt = ',SUM(lmt_sea_salt),
 !     .               MAXVAL(lmt_sea_salt),MINVAL(lmt_sea_salt)
+c
 C***********************************************************************
 C SULFUR & CARBON EMISSIONS
 C***********************************************************************
+c
       IF (test_day.EQ.0) THEN
         print *,'Computing SULFATE emissions for day : ',iday,julien,
      .                                                   step_vent
         CALL condsurfs_new(iday, edgar, flag_dms,
      O                      lmt_so2ff_l, lmt_so2ff_h, lmt_so2nff,
      O                      lmt_so2bb_l, lmt_so2bb_h, lmt_so2ba,
      O                      lmt_so2volc_cont, lmt_altvolc_cont,
      O                      lmt_so2volc_expl, lmt_altvolc_expl,
      O                      lmt_dmsbio, lmt_h2sbio, lmt_dms,lmt_dmsconc)
         print *,'Computing CARBON emissions for day : ',iday,julien,
      .                                                   step_vent
         CALL condsurfc_new(iday,
      O                       lmt_bcff,lmt_bcnff,lmt_bcbb_l,lmt_bcbb_h,
      O                       lmt_bcba,lmt_omff,lmt_omnff,lmt_ombb_l,
      O                       lmt_ombb_h, lmt_omnat, lmt_omba)
         print *,'IDAY = ',iday
         iday=iday+1
         print *,'BCBB_L emissions :',SUM(lmt_bcbb_l), MAXVAL(lmt_bcbb_l)
      .                              ,MINVAL(lmt_bcbb_l)
         print *,'BCBB_H emissions :',SUM(lmt_bcbb_h), MAXVAL(lmt_bcbb_h)
      .                              ,MINVAL(lmt_bcbb_h)
       ENDIF
 !JE      test_day=test_day+1
 !JE      IF (test_day.EQ.(24*2.)) THEN
 !JE        test_day=0 !on remet a zero ttes les 24 h
 !JE        print *,'LAST TIME STEP OF DAY ',julien
 !JE      ENDIF
       jH_day=jH_day+pdtphys/(24.*3600.)
       test_day=test_day+1
       IF (jH_day.GT.(day_resol)/24.) THEN
           print *,'LAST TIME STEP OF DAY ',julien
           test_day=0
           jH_day=jH_init
       ENDIF
 !      PRINT*,'test_day,test_day1',test_day,test_day1
+      END
+  !
+  ENDIF
+  !
+  !***********************************************************************
+  ! SEA SALT EMISSIONS
+  !***********************************************************************
+  !
+  DO i=1,klon
+    pct_ocean(i)=pctsrf(i,is_oce)
+  ENDDO
+  print *,'IS_OCE = ',is_oce
+  CALL seasalt(v10m_ec, u10m_ec, pct_ocean, lmt_sea_salt) !mgSeaSalt/cm2/s
+   ! print *,'SUM, MAX & MIN Sea Salt = ',SUM(lmt_sea_salt),
+  ! .               MAXVAL(lmt_sea_salt),MINVAL(lmt_sea_salt)
+  !
+  !***********************************************************************
+  ! SULFUR & CARBON EMISSIONS
+  !***********************************************************************
+  !
+  IF (test_day.EQ.0) THEN
+    print *,'Computing SULFATE emissions for day : ',iday,julien, &
+          step_vent
+    CALL condsurfs_new(iday, edgar, flag_dms, &
+          lmt_so2ff_l, lmt_so2ff_h, lmt_so2nff, &
+          lmt_so2bb_l, lmt_so2bb_h, lmt_so2ba, &
+          lmt_so2volc_cont, lmt_altvolc_cont, &
+          lmt_so2volc_expl, lmt_altvolc_expl, &
+          lmt_dmsbio, lmt_h2sbio, lmt_dms,lmt_dmsconc)
+    print *,'Computing CARBON emissions for day : ',iday,julien, &
+          step_vent
+    CALL condsurfc_new(iday, &
+          lmt_bcff,lmt_bcnff,lmt_bcbb_l,lmt_bcbb_h, &
+          lmt_bcba,lmt_omff,lmt_omnff,lmt_ombb_l, &
+          lmt_ombb_h, lmt_omnat, lmt_omba)
+    print *,'IDAY = ',iday
+    iday=iday+1
+    print *,'BCBB_L emissions :',SUM(lmt_bcbb_l), MAXVAL(lmt_bcbb_l) &
+          ,MINVAL(lmt_bcbb_l)
+    print *,'BCBB_H emissions :',SUM(lmt_bcbb_h), MAXVAL(lmt_bcbb_h) &
+          ,MINVAL(lmt_bcbb_h)
+  ENDIF
+  !JE      test_day=test_day+1
+  !JE      IF (test_day.EQ.(24*2.)) THEN
+  !JE        test_day=0 !on remet a zero ttes les 24 h
+  !JE        print *,'LAST TIME STEP OF DAY ',julien
+  !JE      ENDIF
+  jH_day=jH_day+pdtphys/(24.*3600.)
+  test_day=test_day+1
+  IF (jH_day.GT.(day_resol)/24.) THEN
+      print *,'LAST TIME STEP OF DAY ',julien
+      test_day=0
+      jH_day=jH_init
+  ENDIF
+   ! PRINT*,'test_day,test_day1',test_day,test_day1
+END SUBROUTINE read_newemissions

LMDZ6/trunk/libf/phylmd/Dust/read_vent.F90

-                      r5245
+                      r5246
       SUBROUTINE read_vent(debutphy, step, nbjour, u10m_ec, v10m_ec)
       USE dimphy
       USE mod_grid_phy_lmdz
       USE mod_phys_lmdz_para
 !      USE write_field_phy
       IMPLICIT NONE
       INCLUDE "dimensions.h"
 c       INCLUDE "dimphy.h"
       INCLUDE "paramet.h"
       INCLUDE "netcdf.inc"
+c
       INTEGER step, nbjour
       LOGICAL debutphy
       real u10m_ec(klon), v10m_ec(klon)
       real u10m_ec_glo(klon_glo), v10m_ec_glo(klon_glo)
+c
 !      real u10m_nc(iip1,jjp1) !, v10m_nc(iip1,jjm) ! dim 97x72
 !      real v10m_nc(iip1,jjp1)  ! dim 97x73
       real u10m_nc_glo(nbp_lon+1,nbp_lat) !, v10m_nc(iip1,jjm) ! dim 97x72
       real v10m_nc_glo(nbp_lon+1,nbp_lat)  ! dim 97x73
       real rcode
       integer ncidu1, varidu1, ncidv1, varidv1
       save ncidu1, varidu1, ncidv1, varidv1
+SUBROUTINE read_vent(debutphy, step, nbjour, u10m_ec, v10m_ec)
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+   ! USE write_field_phy
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+    ! INCLUDE "dimphy.h"
+  INCLUDE "paramet.h"
+  INCLUDE "netcdf.inc"
+  !
+  INTEGER :: step, nbjour
+  LOGICAL :: debutphy
+  real :: u10m_ec(klon), v10m_ec(klon)
+  real :: u10m_ec_glo(klon_glo), v10m_ec_glo(klon_glo)
+  !
+  !  real u10m_nc(iip1,jjp1) !, v10m_nc(iip1,jjm) ! dim 97x72
+  !  real v10m_nc(iip1,jjp1)  ! dim 97x73
+  real :: u10m_nc_glo(nbp_lon+1,nbp_lat) !, v10m_nc(iip1,jjm) ! dim 97x72
+  real :: v10m_nc_glo(nbp_lon+1,nbp_lat)  ! dim 97x73
+  real :: rcode
+  integer :: ncidu1, varidu1, ncidv1, varidv1
+  save ncidu1, varidu1, ncidv1, varidv1
 !$OMP THREADPRIVATE(ncidu1, varidu1, ncidv1, varidv1)
       integer start(4),count(4), status
       integer i, j, ig
+  integer :: start(4),count(4), status
+  integer :: i, j, ig
+c
+  !
 !$OMP MASTER
       IF (is_mpi_root .AND. is_omp_root) THEN
       if (debutphy) then
+c
          ncidu1=NCOPN('u10m.nc',NCNOWRIT,rcode)
          varidu1=NCVID(ncidu1,'U10M',rcode)
          ncidv1=NCOPN('v10m.nc',NCNOWRIT,rcode)
          varidv1=NCVID(ncidv1,'V10M',rcode)
+c
       endif
+c
       start(1)=1
       start(2)=1
       start(4)=0
+  IF (is_mpi_root .AND. is_omp_root) THEN
+  if (debutphy) then
+  !
+     ncidu1=NCOPN('u10m.nc',NCNOWRIT,rcode)
+     varidu1=NCVID(ncidu1,'U10M',rcode)
+     ncidv1=NCOPN('v10m.nc',NCNOWRIT,rcode)
+     varidv1=NCVID(ncidv1,'V10M',rcode)
+  !
+  endif
+  !
+  start(1)=1
+  start(2)=1
+  start(4)=0
 !      count(1)=iip1
       count(1)=nbp_lon+1
 !      count(2)=jjp1
       count(2)=nbp_lat
       count(3)=1
       count(4)=0
+c
       start(3)=step
+c
+   ! count(1)=iip1
+  count(1)=nbp_lon+1
+   ! count(2)=jjp1
+  count(2)=nbp_lat
+  count(3)=1
+  count(4)=0
+  !
+  start(3)=step
+  !
 #ifdef NC_DOUBLE
 !      status=NF_GET_VARA_DOUBLE(ncidu1,varidu1,start,count,u10m_nc)
       status=NF_GET_VARA_DOUBLE(ncidu1,varidu1,start,count,u10m_nc_glo)
+   ! status=NF_GET_VARA_DOUBLE(ncidu1,varidu1,start,count,u10m_nc)
+  status=NF_GET_VARA_DOUBLE(ncidu1,varidu1,start,count,u10m_nc_glo)
 #else
 !      status=NF_GET_VARA_REAL(ncidu1,varidu1,start,count,u10m_nc)
       status=NF_GET_VARA_REAL(ncidu1,varidu1,start,count,u10m_nc_glo)
+   ! status=NF_GET_VARA_REAL(ncidu1,varidu1,start,count,u10m_nc)
+  status=NF_GET_VARA_REAL(ncidu1,varidu1,start,count,u10m_nc_glo)
 #endif
 !       print *,status
+c
+    ! print *,status
+  !
 #ifdef NC_DOUBLE
 !      status=NF_GET_VARA_DOUBLE(ncidv1,varidv1,start,count,v10m_nc)
       status=NF_GET_VARA_DOUBLE(ncidv1,varidv1,start,count,v10m_nc_glo)
+   ! status=NF_GET_VARA_DOUBLE(ncidv1,varidv1,start,count,v10m_nc)
+  status=NF_GET_VARA_DOUBLE(ncidv1,varidv1,start,count,v10m_nc_glo)
 #else
 !      status=NF_GET_VARA_REAL(ncidv1,varidv1,start,count,v10m_nc)
       status=NF_GET_VARA_REAL(ncidv1,varidv1,start,count,v10m_nc_glo)
+   ! status=NF_GET_VARA_REAL(ncidv1,varidv1,start,count,v10m_nc)
+  status=NF_GET_VARA_REAL(ncidv1,varidv1,start,count,v10m_nc_glo)
 #endif
+c
+  !
 !      print *,'beforebidcor u10m_nc', u10m_nc(1,jjp1)
 !      print *,'beforebidcor v10m_nc', v10m_nc(1,jjp1)
+  !  print *,'beforebidcor u10m_nc', u10m_nc(1,jjp1)
+  !  print *,'beforebidcor v10m_nc', v10m_nc(1,jjp1)
 !       print *,status
 !      call correctbid(iim,jjp1,u10m_nc)
 !      call correctbid(iim,jjp1,v10m_nc)
       call correctbid(nbp_lon,nbp_lat,u10m_nc_glo)
       call correctbid(nbp_lon,nbp_lat,v10m_nc_glo)
+  !   print *,status
+  !  call correctbid(iim,jjp1,u10m_nc)
+  !  call correctbid(iim,jjp1,v10m_nc)
+  call correctbid(nbp_lon,nbp_lat,u10m_nc_glo)
+  call correctbid(nbp_lon,nbp_lat,v10m_nc_glo)
 !      print *,'afterbidcor u10m_nc', u10m_nc(1,jjp1)
 !      print *,'afterbidcor v10m_nc', v10m_nc(1,jjp1)
+c
 c--upside down + physical grid
+c
 !      u10m_ec(1)=u10m_nc(1,jjp1)
 !      v10m_ec(1)=v10m_nc(1,jjp1)
       u10m_ec_glo(1)=u10m_nc_glo(1,nbp_lat)
       v10m_ec_glo(1)=v10m_nc_glo(1,nbp_lat)
       ig=2
 !      DO j=2,jjm
 !         DO i = 1, iim
       DO j=2,nbp_lat-1
          DO i = 1, nbp_lon
 !           u10m_ec(ig)=u10m_nc(i,jjp1+1-j)
 !           v10m_ec(ig)=v10m_nc(i,jjp1+1-j)
            u10m_ec_glo(ig)=u10m_nc_glo(i,nbp_lat+1-j)
            v10m_ec_glo(ig)=v10m_nc_glo(i,nbp_lat+1-j)
            ig=ig+1
+!         print *,u10m_ec(ig) ,v10m_ec(ig)
          ENDDO
       ENDDO
       u10m_ec_glo(ig)=u10m_nc_glo(1,1)
       v10m_ec_glo(ig)=v10m_nc_glo(1,1)
+   ! print *,'afterbidcor u10m_nc', u10m_nc(1,jjp1)
+   ! print *,'afterbidcor v10m_nc', v10m_nc(1,jjp1)
+  !
+  !--upside down + physical grid
+  !
+  !  u10m_ec(1)=u10m_nc(1,jjp1)
+  !  v10m_ec(1)=v10m_nc(1,jjp1)
+  u10m_ec_glo(1)=u10m_nc_glo(1,nbp_lat)
+  v10m_ec_glo(1)=v10m_nc_glo(1,nbp_lat)
+  ig=2
+   ! DO j=2,jjm
+   !    DO i = 1, iim
+  DO j=2,nbp_lat-1
+     DO i = 1, nbp_lon
+        ! u10m_ec(ig)=u10m_nc(i,jjp1+1-j)
+        ! v10m_ec(ig)=v10m_nc(i,jjp1+1-j)
+       u10m_ec_glo(ig)=u10m_nc_glo(i,nbp_lat+1-j)
+       v10m_ec_glo(ig)=v10m_nc_glo(i,nbp_lat+1-j)
+       ig=ig+1
+      ! print *,u10m_ec(ig) ,v10m_ec(ig)
+     ENDDO
+  ENDDO
+  u10m_ec_glo(ig)=u10m_nc_glo(1,1)
+  v10m_ec_glo(ig)=v10m_nc_glo(1,1)
 !      end if master
       ENDIF
+   ! end if master
+  ENDIF
 !$OMP END MASTER
 !$OMP BARRIER
       CALL scatter(u10m_ec_glo,u10m_ec)
       CALL scatter(v10m_ec_glo,v10m_ec)
+  CALL scatter(u10m_ec_glo,u10m_ec)
+  CALL scatter(v10m_ec_glo,v10m_ec)
 !      print *,'JE  tamagno viento ig= ', ig
 !      print *,'READ_VENT U = ',SUM(u10m_ec),MINVAL(u10m_ec),
 !     .                                      MAXVAL(u10m_ec)
 !      print *,'READ_VENT V = ',SUM(v10m_ec),MINVAL(v10m_ec),
 !     .                                      MAXVAL(v10m_ec)
 !       print *,'u v 1 ', u10m_ec(1),v10m_ec(1)
 !       print *,'u v klon ', u10m_ec(klon),v10m_ec(klon)
       RETURN
+      END
+   ! print *,'JE  tamagno viento ig= ', ig
+   ! print *,'READ_VENT U = ',SUM(u10m_ec),MINVAL(u10m_ec),
+  ! .                                      MAXVAL(u10m_ec)
+  !  print *,'READ_VENT V = ',SUM(v10m_ec),MINVAL(v10m_ec),
+  ! .                                      MAXVAL(v10m_ec)
+  !   print *,'u v 1 ', u10m_ec(1),v10m_ec(1)
+  !   print *,'u v klon ', u10m_ec(klon),v10m_ec(klon)
+  RETURN
+END SUBROUTINE read_vent
 c added by JE from the nh SPLA, dyn3d/read_reanalyse.F which is not available any more
       subroutine correctbid(iim,nl,x)
       integer iim,nl
       real x(iim+1,nl)
       integer i,l
       real zz
+! added by JE from the nh SPLA, dyn3d/read_reanalyse.F which is not available any more
+subroutine correctbid(iim,nl,x)
+  integer :: iim,nl
+  real :: x(iim+1,nl)
+  integer :: i,l
+  real :: zz
       do l=1,nl
          do i=2,iim-1
             if(abs(x(i,l)).gt.1.e10) then
                zz=0.5*(x(i-1,l)+x(i+1,l))
 c              print*,'correction ',i,l,x(i,l),zz
                x(i,l)=zz
             endif
          enddo
       enddo
+  do l=1,nl
+     do i=2,iim-1
+        if(abs(x(i,l)).gt.1.e10) then
+           zz=0.5*(x(i-1,l)+x(i+1,l))
+           ! print*,'correction ',i,l,x(i,l),zz
+           x(i,l)=zz
+        endif
+     enddo
+  enddo
       return
       end
+  return
+end subroutine correctbid

LMDZ6/trunk/libf/phylmd/Dust/seasalt.f90

-                      r5245
+                      r5246
+c       This subroutine estimateis Sea Salt emission fluxes over
+c       Oceanic surfaces.
+c
+      SUBROUTINE seasalt(v_10m, u_10m, pct_ocean, lmt_sea_salt)
+      USE dimphy
+      IMPLICIT NONE
+c
+      INCLUDE "dimensions.h"
+      INCLUDE "chem.h"
+      INCLUDE "chem_spla.h"
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOECUMF.h"
+c
+      INTEGER i, bin                 !local variables
+      REAL pct_ocean(klon)           !hfraction of Ocean in each grid
+      REAL v_10m(klon), u_10m(klon)  !V&H components of wind @10 m
+      REAL w_speed_10m(klon)         !wind speed at 10m from surface
+      REAL lmt_sea_salt(klon,ss_bins)!sea salt emission flux - mg/m2/s
+      REAL sea_salt_flux(ss_bins)    !sea salt emission flux per unit wind speed
+  ! This subroutine estimateis Sea Salt emission fluxes over
+  ! Oceanic surfaces.
+!
+SUBROUTINE seasalt(v_10m, u_10m, pct_ocean, lmt_sea_salt)
+      REAL wind, ocean
+c
+c------Sea salt emission fluxes for each size bin calculated
+c------based on on parameterisation of Gong et al. (1997).
+c------Fluxes of sea salt for each size bin are given in mg/m^2/sec
+c------at wind speed of 1 m/s at 10m height (at 80% RH).
+c------Fluxes at various wind speeds (@10 m from sea
+c------surfaces are estimated using relationship: F=flux*U_10^3.14
+c
+cnhl for size bin of 0.03-0.5 and 0.5-20
+      DATA sea_salt_flux/4.5E-09,8.7E-7/
+  USE dimphy
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "chem_spla.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h"
+  !
+  INTEGER :: i, bin                 !local variables
+  REAL :: pct_ocean(klon)           !hfraction of Ocean in each grid
+  REAL :: v_10m(klon), u_10m(klon)  !V&H components of wind @10 m
+  REAL :: w_speed_10m(klon)         !wind speed at 10m from surface
+  REAL :: lmt_sea_salt(klon,ss_bins)!sea salt emission flux - mg/m2/s
+  REAL :: sea_salt_flux(ss_bins)    !sea salt emission flux per unit wind speed
+      DO i=1, klon
+      w_speed_10m(i)= (v_10m(i)**2.0+u_10m(i)**2.0)**0.5
+      ENDDO
+c
+      DO bin=1,ss_bins
+      wind=0.0
+      ocean=0.0
+      DO i=1, klon
+      lmt_sea_salt(i,bin)=sea_salt_flux(bin)*(w_speed_10m(i)**3.41)
+     . *pct_ocean(i)*1.e-4*1.e-3                       !g/cm2/s
+      wind=wind+w_speed_10m(i)
+      ocean=ocean+pct_ocean(i)
+      ENDDO
+!      print *,'Sea Salt flux = ',sea_salt_flux(bin)
+      ENDDO
+!      print *,'SUM OF WIND = ',wind
+!      print *,'SUM OF OCEAN SURFACE = ',ocean
+      RETURN
+      END
+  REAL :: wind, ocean
+  !
+  !------Sea salt emission fluxes for each size bin calculated
+  !------based on on parameterisation of Gong et al. (1997).
+  !------Fluxes of sea salt for each size bin are given in mg/m^2/sec
+  !------at wind speed of 1 m/s at 10m height (at 80% RH).
+  !------Fluxes at various wind speeds (@10 m from sea
+  !------surfaces are estimated using relationship: F=flux*U_10^3.14
+  !
+  !nhl for size bin of 0.03-0.5 and 0.5-20
+  DATA sea_salt_flux/4.5E-09,8.7E-7/
+  DO i=1, klon
+  w_speed_10m(i)= (v_10m(i)**2.0+u_10m(i)**2.0)**0.5
+  ENDDO
+  !
+  DO bin=1,ss_bins
+  wind=0.0
+  ocean=0.0
+  DO i=1, klon
+  lmt_sea_salt(i,bin)=sea_salt_flux(bin)*(w_speed_10m(i)**3.41) &
+        *pct_ocean(i)*1.e-4*1.e-3                       !g/cm2/s
+  wind=wind+w_speed_10m(i)
+  ocean=ocean+pct_ocean(i)
+  ENDDO
+   ! print *,'Sea Salt flux = ',sea_salt_flux(bin)
+  ENDDO
+   ! print *,'SUM OF WIND = ',wind
+   ! print *,'SUM OF OCEAN SURFACE = ',ocean
+  RETURN
+END SUBROUTINE seasalt

LMDZ6/trunk/libf/phylmd/Dust/sediment_mod.f90

-                      r5245
+                      r5246
+c----- This subroutine calculates the sedimentation flux of Tracers
+c
+      SUBROUTINE sediment_mod(t_seri,pplay,zrho,paprs,time_step,RHcl,
      .                                       id_coss,id_codu,id_scdu,
      .                                        ok_chimeredust,
      .                           sed_ss,sed_dust,sed_dustsco,
      .                        sed_ss3D,sed_dust3D,sed_dustsco3D,tr_seri)
 cnhl     .                                       xlon,xlat,
+c
        USE dimphy
        USE infotrac
       IMPLICIT NONE
+c
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
 c       INCLUDE "dimphy.h"
       INCLUDE "YOMCST.h"
       INCLUDE "YOECUMF.h"
+c
        REAL RHcl(klon,klev)     ! humidite relative ciel clair
        REAL tr_seri(klon, klev,nbtr) !conc of tracers
        REAL sed_ss(klon) !sedimentation flux of Sea Salt (g/m2/s)
        REAL sed_dust(klon) !sedimentation flux of dust (g/m2/s)
        REAL sed_dustsco(klon) !sedimentation flux of scoarse  dust (g/m2/s)
        REAL sed_ss3D(klon,klev) !sedimentation flux of Sea Salt (g/m2/s)
        REAL sed_dust3D(klon,klev) !sedimentation flux of dust (g/m2/s)
        REAL sed_dustsco3D(klon,klev) !sedimentation flux of scoarse  dust (g/m2/s)
        REAL t_seri(klon, klev)   !Temperature at mid points of Z (K)
        REAL v_dep_ss(klon,klev)  ! sed. velocity for SS m/s
        REAL v_dep_dust(klon,klev)  ! sed. velocity for dust m/s
        REAL v_dep_dustsco(klon,klev)  ! sed. velocity for dust m/s
        REAL pplay(klon, klev)    !pressure at mid points of Z (Pa)
        REAL zrho(klon, klev)     !Density of air at mid points of Z (kg/m3)
        REAL paprs(klon, klev+1)    !pressure at interface of layers Z (Pa)
        REAL time_step            !time step (sec)
        LOGICAL ok_chimeredust
        REAL xlat(klon)       ! latitudes pour chaque point
        REAL xlon(klon)       ! longitudes pour chaque point
        INTEGER id_coss,id_codu,id_scdu
+c
 c------local variables
+c
        INTEGER i, k, nbre_RH
        PARAMETER(nbre_RH=12)
+c
        REAL lambda, ss_g
        REAL mmd_ss      !mass median diameter of SS (um)
        REAL mmd_dust          !mass median diameter of dust (um)
        REAL mmd_dustsco          !mass median diameter of scoarse dust (um)
        REAL rho_ss(nbre_RH),rho_ss1 !density of sea salt (kg/m3)
        REAL rho_dust          !density of dust(kg/m3)
        REAL v_stokes, CC, v_sed, ss_growth_f(nbre_RH)
        REAL sed_flux(klon,klev)  ! sedimentation flux g/m2/s
        REAL air_visco(klon,klev)
        REAL zdz(klon,klev)       ! layers height (m)
        REAL temp                 ! temperature in degree Celius
+c
        INTEGER RH_num
        REAL RH_MAX, DELTA, rh, RH_tab(nbre_RH)
        PARAMETER (RH_MAX=95.)
+c
        DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+c
+c
        DATA rho_ss/2160. ,2160. ,2160.,  2160,  1451.6, 1367.9,
      .             1302.9,1243.2,1182.7, 1149.5,1111.6, 1063.1/
+c
        DATA ss_growth_f/0.503, 0.503, 0.503, 0.503, 0.724, 0.782,
      .                  0.838, 0.905, 1.000, 1.072, 1.188, 1.447/
+c
+c
        mmd_ss=12.7   !dia -um at 80% for bin 0.5-20 um but 90% of real mmd
 !               obsolete      mmd_dust=2.8  !micrometer for bin 0.5-20 and 0.5-10 um
 ! 4tracer SPLA:       mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
 !3days       mmd_dust=3.333464  !micrometer for bin 0.5-20 and 0.5-10 um
 !3days       mmd_dustsco=12.91315  !micrometer for bin 0.5-20 and 0.5-10 um
 !JE20140911       mmd_dust=3.002283  !micrometer for bin 0.5-20 and 0.5-10 um
 !JE20140911       mmd_dustsco=13.09771  !micrometer for bin 0.5-20 and 0.5-10 um
 !JE20140911        mmd_dust=5.156346  !micrometer for bin 0.5-20 and 0.5-10 um
 !JE20140911        mmd_dustsco=15.56554  !micrometer for bin 0.5-20 and 0.5-10 um
         IF (ok_chimeredust) THEN
 !JE20150212<< : changes in ustar in dustmod changes emission distribution
 !        mmd_dust=3.761212  !micrometer for bin 0.5-3 and 0.5-10 um
 !        mmd_dustsco=15.06167  !micrometer for bin 3-20 and 0.5-10 um
 !JE20150212>>
 !JE20150618: Change in div3 of dustmod changes distribution. now is div3=6
 !div=3        mmd_dust=3.983763
+!div=3        mmd_dustsco=15.10854
         mmd_dust=3.898047
         mmd_dustsco=15.06167
         ELSE
         mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
         mmd_dustsco=100. ! absurd value, bin not used in this scheme
         ENDIF
        rho_dust=2600. !kg/m3
+c
 c--------- Air viscosity (poise=0.1 kg/m-sec)-----------
+c
        DO k=1, klev
        DO i=1, klon
+c
        zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+c
        temp=t_seri(i,k)-RTT
+c
        IF (temp.LT.0.) THEN
          air_visco(i,k)=(1.718+0.0049*temp-1.2e-5*temp*temp)*1.e-4
        ELSE
          air_visco(i,k)=(1.718+0.0049*temp)*1.e-4
        ENDIF
+c
        ENDDO
        ENDDO
+c
 c--------- for Sea Salt -------------------
+c
+c
+c
        IF(id_coss>0) THEN
        DO k=1, klev
        DO i=1,klon
+c
 c---cal. correction factor hygroscopic growth of aerosols
+c
         rh=MIN(RHcl(i,k)*100.,RH_MAX)
         RH_num = INT( rh/10. + 1.)
         IF (rh.gt.85.) RH_num=10
         IF (rh.gt.90.) RH_num=11
         DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+c
         ss_g=ss_growth_f(rh_num) +
      .       DELTA*(ss_growth_f(RH_num+1)-ss_growth_f(RH_num))
         rho_ss1=rho_ss(rh_num) +
      .       DELTA*(rho_ss(RH_num+1)-rho_ss(RH_num))
+c
         v_stokes=RG*(rho_ss1-zrho(i,k))*      !m/sec
      .           (mmd_ss*ss_g)*(mmd_ss*ss_g)*
      .           1.e-12/(18.0*air_visco(i,k)/10.)
+c
        lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
+c
        CC=1.0+1.257*lambda/(mmd_ss*ss_g)/1.e6  ! C-correction factor
+c
        v_sed=v_stokes*CC                       ! m/sec !orig
+c
 c---------check for v_sed*dt<zdz
+c
        IF (v_sed*time_step.GT.zdz(i,k)) THEN
          v_sed=zdz(i,k)/time_step
        ENDIF
+c
        v_dep_ss(i,k)= v_sed
        sed_flux(i,k)= tr_seri(i,k,id_coss)*v_sed !g/cm3*m/sec
        !sed_ss3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
       ! conc_sed_ss3D(i,k)=sed_flux(i,k)*1.e6      !g/m3*sec !!!!!!!
+c
        ENDDO          !klon
        ENDDO          !klev
+c
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        sed_ss3D(:,:)=0.0  ! initialisation
        DO k=1, klev
        DO i=1, klon
        sed_ss3D(i,k)=sed_ss3D(i,k)-
      .        sed_flux(i,k)/zdz(i,k) !!!!!!!!!!!!!!!!!!!!!!
        ENDDO          !klon
        ENDDO          !klev
+c
        DO k=1, klev-1
        DO i=1, klon
         sed_ss3D(i,k)=sed_ss3D(i,k)+
      .                  sed_flux(i,k+1)/zdz(i,k) !!!!!!!!
        ENDDO          !klon
        ENDDO          !klev
       DO k = 1, klev
       DO i = 1, klon
           tr_seri(i,k,id_coss)=tr_seri(i,k,id_coss)+
      s   sed_ss3D(i,k)*time_step
       ENDDO
       ENDDO
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+c
        DO i=1, klon
          sed_ss(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
        ENDDO          !klon
        ELSE
         DO i=1, klon
           sed_ss(i)=0.
         ENDDO
        ENDIF
+c
+c
 c--------- For dust ------------------
+c
+c
        IF(id_codu>0) THEN
        DO k=1, klev
        DO i=1,klon
+c
         v_stokes=RG*(rho_dust-zrho(i,k))*      !m/sec
      .           mmd_dust*mmd_dust*
      .           1.e-12/(18.0*air_visco(i,k)/10.)
+c
        lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
        CC=1.0+1.257*lambda/(mmd_dust)/1.e6        !dimensionless
        v_sed=v_stokes*CC                       !m/sec
+c
 c---------check for v_sed*dt<zdz
+c
        IF (v_sed*time_step.GT.zdz(i,k)) THEN
          v_sed=zdz(i,k)/time_step
        ENDIF
+c
        v_dep_dust(i,k)= v_sed
        sed_flux(i,k)  = tr_seri(i,k,id_codu)*v_sed !g/cm3.m/sec
        !sed_dust3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
+c
        ENDDO          !klon
        ENDDO          !klev
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        sed_dust3D(:,:)=0.0  ! initialisation
        DO k=1, klev
        DO i=1, klon
        sed_dust3D(i,k)=sed_dust3D(i,k)-
      .                  sed_flux(i,k)/zdz(i,k)
        ENDDO          !klon
        ENDDO          !klev
+c
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        DO k=1, klev-1
        DO i=1, klon
         sed_dust3D(i,k)=sed_dust3D(i,k) +
      .                  sed_flux(i,k+1)/zdz(i,k)
        ENDDO          !klon
        ENDDO          !klev
+c
       DO k = 1, klev
       DO i = 1, klon
          tr_seri(i,k,id_codu)=tr_seri(i,k,id_codu)+
      s    sed_dust3D(i,k)*time_step
       ENDDO
       ENDDO
        DO i=1, klon
          sed_dust(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
        ENDDO          !klon
        ELSE
         DO i=1, klon
           sed_dust(i)=0.
         ENDDO
        ENDIF
+c
 c--------- For scoarse  dust ------------------
+c
+c
        IF(id_scdu>0) THEN
        DO k=1, klev
        DO i=1,klon
+c
         v_stokes=RG*(rho_dust-zrho(i,k))*      !m/sec
      .           mmd_dustsco*mmd_dustsco*
      .           1.e-12/(18.0*air_visco(i,k)/10.)
+c
        lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
        CC=1.0+1.257*lambda/(mmd_dustsco)/1.e6        !dimensionless
        v_sed=v_stokes*CC                       !m/sec
+c
 c---------check for v_sed*dt<zdz
        IF (v_sed*time_step.GT.zdz(i,k)) THEN
          v_sed=zdz(i,k)/time_step
        ENDIF
+c
        v_dep_dustsco(i,k)= v_sed
        sed_flux(i,k)     = tr_seri(i,k,id_scdu)*v_sed !g/cm3.m/sec
        !sed_dustsco3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
+c
        ENDDO          !klon
        ENDDO          !klev
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        sed_dustsco3D(:,:)=0.0  ! initialisation
        DO k=1, klev
        DO i=1, klon
        sed_dustsco3D(i,k)=sed_dustsco3D(i,k)-
      .                  sed_flux(i,k)/zdz(i,k)
        ENDDO          !klon
        ENDDO          !klev
+c
        DO k=1, klev-1
        DO i=1, klon
         sed_dustsco3D(i,k)=sed_dustsco3D(i,k) +
      .                  sed_flux(i,k+1)/zdz(i,k)
        ENDDO          !klon
        ENDDO          !klev
       DO k = 1, klev
       DO i = 1, klon
        tr_seri(i,k,id_scdu)=tr_seri(i,k,id_scdu)+
      s  sed_dustsco3D(i,k)*time_step
       ENDDO
       ENDDO
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+c
        DO i=1, klon
          sed_dustsco(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
        ENDDO          !klon
        ELSE
         DO i=1, klon
           sed_dustsco(i)=0.
         ENDDO
        ENDIF
+c
+c
        RETURN
+       END
+!----- This subroutine calculates the sedimentation flux of Tracers
+!
+SUBROUTINE sediment_mod(t_seri,pplay,zrho,paprs,time_step,RHcl, &
+        id_coss,id_codu,id_scdu, &
+        ok_chimeredust, &
+        sed_ss,sed_dust,sed_dustsco, &
+        sed_ss3D,sed_dust3D,sed_dustsco3D,tr_seri)
+  !nhl     .                                       xlon,xlat,
+  !
+   USE dimphy
+   USE infotrac
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+    ! INCLUDE "dimphy.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h"
+  !
+   REAL :: RHcl(klon,klev)     ! humidite relative ciel clair
+   REAL :: tr_seri(klon, klev,nbtr) !conc of tracers
+   REAL :: sed_ss(klon) !sedimentation flux of Sea Salt (g/m2/s)
+   REAL :: sed_dust(klon) !sedimentation flux of dust (g/m2/s)
+   REAL :: sed_dustsco(klon) !sedimentation flux of scoarse  dust (g/m2/s)
+   REAL :: sed_ss3D(klon,klev) !sedimentation flux of Sea Salt (g/m2/s)
+   REAL :: sed_dust3D(klon,klev) !sedimentation flux of dust (g/m2/s)
+   REAL :: sed_dustsco3D(klon,klev) !sedimentation flux of scoarse  dust (g/m2/s)
+   REAL :: t_seri(klon, klev)   !Temperature at mid points of Z (K)
+   REAL :: v_dep_ss(klon,klev)  ! sed. velocity for SS m/s
+   REAL :: v_dep_dust(klon,klev)  ! sed. velocity for dust m/s
+   REAL :: v_dep_dustsco(klon,klev)  ! sed. velocity for dust m/s
+   REAL :: pplay(klon, klev)    !pressure at mid points of Z (Pa)
+   REAL :: zrho(klon, klev)     !Density of air at mid points of Z (kg/m3)
+   REAL :: paprs(klon, klev+1)    !pressure at interface of layers Z (Pa)
+   REAL :: time_step            !time step (sec)
+   LOGICAL :: ok_chimeredust
+   REAL :: xlat(klon)       ! latitudes pour chaque point
+   REAL :: xlon(klon)       ! longitudes pour chaque point
+   INTEGER :: id_coss,id_codu,id_scdu
+  !
+  !------local variables
+  !
+   INTEGER :: i, k, nbre_RH
+   PARAMETER(nbre_RH=12)
+  !
+   REAL :: lambda, ss_g
+   REAL :: mmd_ss      !mass median diameter of SS (um)
+   REAL :: mmd_dust          !mass median diameter of dust (um)
+   REAL :: mmd_dustsco          !mass median diameter of scoarse dust (um)
+   REAL :: rho_ss(nbre_RH),rho_ss1 !density of sea salt (kg/m3)
+   REAL :: rho_dust          !density of dust(kg/m3)
+   REAL :: v_stokes, CC, v_sed, ss_growth_f(nbre_RH)
+   REAL :: sed_flux(klon,klev)  ! sedimentation flux g/m2/s
+   REAL :: air_visco(klon,klev)
+   REAL :: zdz(klon,klev)       ! layers height (m)
+   REAL :: temp                 ! temperature in degree Celius
+  !
+   INTEGER :: RH_num
+   REAL :: RH_MAX, DELTA, rh, RH_tab(nbre_RH)
+   PARAMETER (RH_MAX=95.)
+  !
+   DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+  !
+  !
+   DATA rho_ss/2160. ,2160. ,2160.,  2160,  1451.6, 1367.9, &
+.9,1243.2,1182.7, 1149.5,1111.6, 1063.1/
+  !
+   DATA ss_growth_f/0.503, 0.503, 0.503, 0.503, 0.724, 0.782, &
+.838, 0.905, 1.000, 1.072, 1.188, 1.447/
+  !
+  !
+   mmd_ss=12.7   !dia -um at 80% for bin 0.5-20 um but 90% of real mmd
+            ! obsolete      mmd_dust=2.8  !micrometer for bin 0.5-20 and 0.5-10 um
+  ! 4tracer SPLA:       mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
+  !3days       mmd_dust=3.333464  !micrometer for bin 0.5-20 and 0.5-10 um
+  !3days       mmd_dustsco=12.91315  !micrometer for bin 0.5-20 and 0.5-10 um
+  !JE20140911       mmd_dust=3.002283  !micrometer for bin 0.5-20 and 0.5-10 um
+  !JE20140911       mmd_dustsco=13.09771  !micrometer for bin 0.5-20 and 0.5-10 um
+  !JE20140911        mmd_dust=5.156346  !micrometer for bin 0.5-20 and 0.5-10 um
+  !JE20140911        mmd_dustsco=15.56554  !micrometer for bin 0.5-20 and 0.5-10 um
+    IF (ok_chimeredust) THEN
+  !JE20150212<< : changes in ustar in dustmod changes emission distribution
+     ! mmd_dust=3.761212  !micrometer for bin 0.5-3 and 0.5-10 um
+     ! mmd_dustsco=15.06167  !micrometer for bin 3-20 and 0.5-10 um
+  !JE20150212>>
+  !JE20150618: Change in div3 of dustmod changes distribution. now is div3=6
+  !div=3        mmd_dust=3.983763
+  !div=3        mmd_dustsco=15.10854
+    mmd_dust=3.898047
+    mmd_dustsco=15.06167
+    ELSE
+    mmd_dust=11.0  !micrometer for bin 0.5-20 and 0.5-10 um
+    mmd_dustsco=100. ! absurd value, bin not used in this scheme
+    ENDIF
+   rho_dust=2600. !kg/m3
+  !
+  !--------- Air viscosity (poise=0.1 kg/m-sec)-----------
+  !
+   DO k=1, klev
+   DO i=1, klon
+  !
+   zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+  !
+   temp=t_seri(i,k)-RTT
+  !
+   IF (temp.LT.0.) THEN
+     air_visco(i,k)=(1.718+0.0049*temp-1.2e-5*temp*temp)*1.e-4
+   ELSE
+     air_visco(i,k)=(1.718+0.0049*temp)*1.e-4
+   ENDIF
+  !
+   ENDDO
+   ENDDO
+  !
+  !--------- for Sea Salt -------------------
+  !
+  !
+  !
+   IF(id_coss>0) THEN
+   DO k=1, klev
+   DO i=1,klon
+  !
+  !---cal. correction factor hygroscopic growth of aerosols
+  !
+    rh=MIN(RHcl(i,k)*100.,RH_MAX)
+    RH_num = INT( rh/10. + 1.)
+    IF (rh.gt.85.) RH_num=10
+    IF (rh.gt.90.) RH_num=11
+    DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+  !
+    ss_g=ss_growth_f(rh_num) + &
+          DELTA*(ss_growth_f(RH_num+1)-ss_growth_f(RH_num))
+    rho_ss1=rho_ss(rh_num) + &
+          DELTA*(rho_ss(RH_num+1)-rho_ss(RH_num))
+  !
+    v_stokes=RG*(rho_ss1-zrho(i,k))* & !m/sec
+          (mmd_ss*ss_g)*(mmd_ss*ss_g)* &
+.e-12/(18.0*air_visco(i,k)/10.)
+  !
+   lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
+  !
+   CC=1.0+1.257*lambda/(mmd_ss*ss_g)/1.e6  ! C-correction factor
+  !
+   v_sed=v_stokes*CC                       ! m/sec !orig
+  !
+  !---------check for v_sed*dt<zdz
+  !
+   IF (v_sed*time_step.GT.zdz(i,k)) THEN
+     v_sed=zdz(i,k)/time_step
+   ENDIF
+  !
+   v_dep_ss(i,k)= v_sed
+   sed_flux(i,k)= tr_seri(i,k,id_coss)*v_sed !g/cm3*m/sec
+   ! !sed_ss3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
+  ! ! conc_sed_ss3D(i,k)=sed_flux(i,k)*1.e6      !g/m3*sec !!!!!!!
+  !
+   ENDDO          !klon
+   ENDDO          !klev
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   sed_ss3D(:,:)=0.0  ! initialisation
+   DO k=1, klev
+   DO i=1, klon
+   sed_ss3D(i,k)=sed_ss3D(i,k)- &
+         sed_flux(i,k)/zdz(i,k) !!!!!!!!!!!!!!!!!!!!!!
+   ENDDO          !klon
+   ENDDO          !klev
+  !
+   DO k=1, klev-1
+   DO i=1, klon
+    sed_ss3D(i,k)=sed_ss3D(i,k)+ &
+          sed_flux(i,k+1)/zdz(i,k) !!!!!!!!
+   ENDDO          !klon
+   ENDDO          !klev
+  DO k = 1, klev
+  DO i = 1, klon
+      tr_seri(i,k,id_coss)=tr_seri(i,k,id_coss)+ &
+            sed_ss3D(i,k)*time_step
+  ENDDO
+  ENDDO
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+   DO i=1, klon
+     sed_ss(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
+   ENDDO          !klon
+   ELSE
+    DO i=1, klon
+      sed_ss(i)=0.
+    ENDDO
+   ENDIF
+  !
+  !
+  !--------- For dust ------------------
+  !
+  !
+   IF(id_codu>0) THEN
+   DO k=1, klev
+   DO i=1,klon
+  !
+    v_stokes=RG*(rho_dust-zrho(i,k))* & !m/sec
+          mmd_dust*mmd_dust* &
+.e-12/(18.0*air_visco(i,k)/10.)
+  !
+   lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
+   CC=1.0+1.257*lambda/(mmd_dust)/1.e6        !dimensionless
+   v_sed=v_stokes*CC                       !m/sec
+  !
+  !---------check for v_sed*dt<zdz
+  !
+   IF (v_sed*time_step.GT.zdz(i,k)) THEN
+     v_sed=zdz(i,k)/time_step
+   ENDIF
+  !
+   v_dep_dust(i,k)= v_sed
+   sed_flux(i,k)  = tr_seri(i,k,id_codu)*v_sed !g/cm3.m/sec
+   ! !sed_dust3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
+  !
+   ENDDO          !klon
+   ENDDO          !klev
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   sed_dust3D(:,:)=0.0  ! initialisation
+   DO k=1, klev
+   DO i=1, klon
+   sed_dust3D(i,k)=sed_dust3D(i,k)- &
+         sed_flux(i,k)/zdz(i,k)
+   ENDDO          !klon
+   ENDDO          !klev
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   DO k=1, klev-1
+   DO i=1, klon
+    sed_dust3D(i,k)=sed_dust3D(i,k) + &
+          sed_flux(i,k+1)/zdz(i,k)
+   ENDDO          !klon
+   ENDDO          !klev
+  !
+  DO k = 1, klev
+  DO i = 1, klon
+     tr_seri(i,k,id_codu)=tr_seri(i,k,id_codu)+ &
+           sed_dust3D(i,k)*time_step
+  ENDDO
+  ENDDO
+   DO i=1, klon
+     sed_dust(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
+   ENDDO          !klon
+   ELSE
+    DO i=1, klon
+      sed_dust(i)=0.
+    ENDDO
+   ENDIF
+  !
+  !--------- For scoarse  dust ------------------
+  !
+  !
+   IF(id_scdu>0) THEN
+   DO k=1, klev
+   DO i=1,klon
+  !
+    v_stokes=RG*(rho_dust-zrho(i,k))* & !m/sec
+          mmd_dustsco*mmd_dustsco* &
+.e-12/(18.0*air_visco(i,k)/10.)
+  !
+   lambda=6.6*1.e-8*(103125/pplay(i,k))*(t_seri(i,k)/293.15)
+   CC=1.0+1.257*lambda/(mmd_dustsco)/1.e6        !dimensionless
+   v_sed=v_stokes*CC                       !m/sec
+  !
+  !---------check for v_sed*dt<zdz
+   IF (v_sed*time_step.GT.zdz(i,k)) THEN
+     v_sed=zdz(i,k)/time_step
+   ENDIF
+  !
+   v_dep_dustsco(i,k)= v_sed
+   sed_flux(i,k)     = tr_seri(i,k,id_scdu)*v_sed !g/cm3.m/sec
+   ! !sed_dustsco3D(i,k)= -sed_flux(i,k)/zdz(i,k)      !g/cm3*sec !!!!!!!
+  !
+   ENDDO          !klon
+   ENDDO          !klev
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   sed_dustsco3D(:,:)=0.0  ! initialisation
+   DO k=1, klev
+   DO i=1, klon
+   sed_dustsco3D(i,k)=sed_dustsco3D(i,k)- &
+         sed_flux(i,k)/zdz(i,k)
+   ENDDO          !klon
+   ENDDO          !klev
+  !
+   DO k=1, klev-1
+   DO i=1, klon
+    sed_dustsco3D(i,k)=sed_dustsco3D(i,k) + &
+          sed_flux(i,k+1)/zdz(i,k)
+   ENDDO          !klon
+   ENDDO          !klev
+  DO k = 1, klev
+  DO i = 1, klon
+   tr_seri(i,k,id_scdu)=tr_seri(i,k,id_scdu)+ &
+         sed_dustsco3D(i,k)*time_step
+  ENDDO
+  ENDDO
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+   DO i=1, klon
+     sed_dustsco(i)=sed_flux(i,1)*1.e6*1.e3    !--unit mg/m2/s
+   ENDDO          !klon
+   ELSE
+    DO i=1, klon
+      sed_dustsco(i)=0.
+    ENDDO
+   ENDIF
+  !
+  !
+   RETURN
+END SUBROUTINE sediment_mod

LMDZ6/trunk/libf/phylmd/Dust/tiedqneg.f90

-                      r5245
+                      r5246
       SUBROUTINE tiedqneg (pres_h,q,d_q)
+c
       USE dimphy
       IMPLICIT none
 c======================================================================
 c Auteur(s): CG (LGGE/CNRS) date: 19950201
 c            O. Boucher (LOA/CNRS) date 19961125
 c Objet:  Correction eventuelle des valeurs negatives d'humidite
+c induites par le schema de convection de Tiedke
 c======================================================================
 c Arguments:
 c pres_h--input-R-la valeur de la pression aux interfaces
 c q-------input-R-quantite de traceur
 c d_q-----input-output-R-increment du traceur
 c======================================================================
+c
       INCLUDE "dimensions.h"
 c       INCLUDE "dimphy.h"
       REAL pres_h(klon,klev+1)
       REAL q(klon,klev)
       REAL d_q(klon,klev)
       INTEGER nb_neg
       INTEGER i, l
+c
       REAL qmin
       PARAMETER (qmin=0.0)
+c
       DO l = klev,2,-1
         nb_neg = 0
         DO i = 1,klon
           IF (q(i,l)+d_q(i,l).LT.qmin) THEN
           nb_neg = nb_neg + 1
           d_q(i,l-1) = d_q(i,l-1) + (q(i,l)+d_q(i,l)-qmin)
      .       *(pres_h(i,l)-pres_h(i,l+1))/(pres_h(i,l-1)-pres_h(i,l))
             d_q(i,l) = qmin - q(i,l)
           ENDIF
         ENDDO
+c        IF (nb_neg.NE.0) THEN
 c        PRINT *,'niveau ', l,' ' , nb_neg, ' valeurs negatives'
 c        ENDIF
       ENDDO
+c
       DO l = 1, klev-1
         nb_neg = 0
         DO i = 1,klon
           IF (q(i,l)+d_q(i,l).LT.qmin) THEN
           nb_neg = nb_neg + 1
           d_q(i,l+1) = d_q(i,l+1) + (q(i,l)+d_q(i,l)-qmin)
      .      *(pres_h(i,l)-pres_h(i,l+1))/(pres_h(i,l+1)-pres_h(i,l+2))
           d_q(i,l) = qmin - q(i,l)
           ENDIF
         ENDDO
+c        IF (nb_neg.NE.0) THEN
 c        PRINT *,'niveau ', l,' ' , nb_neg, ' valeurs negatives'
 c        ENDIF
       ENDDO
+c
       l = klev
       DO i = 1,klon
         IF (q(i,l)+d_q(i,l).LT.qmin) THEN
           d_q(i,l) = qmin - q(i,l)
         ENDIF
       ENDDO
+c
       RETURN
+      END
+SUBROUTINE tiedqneg (pres_h,q,d_q)
+  !
+  USE dimphy
+  IMPLICIT none
+  !======================================================================
+  ! Auteur(s): CG (LGGE/CNRS) date: 19950201
+         ! O. Boucher (LOA/CNRS) date 19961125
+  ! Objet:  Correction eventuelle des valeurs negatives d'humidite
+  ! induites par le schema de convection de Tiedke
+  !======================================================================
+  ! Arguments:
+  ! pres_h--input-R-la valeur de la pression aux interfaces
+  ! q-------input-R-quantite de traceur
+  ! d_q-----input-output-R-increment du traceur
+  !======================================================================
+  !
+  INCLUDE "dimensions.h"
+    ! INCLUDE "dimphy.h"
+  REAL :: pres_h(klon,klev+1)
+  REAL :: q(klon,klev)
+  REAL :: d_q(klon,klev)
+  INTEGER :: nb_neg
+  INTEGER :: i, l
+  !
+  REAL :: qmin
+  PARAMETER (qmin=0.0)
+  !
+  DO l = klev,2,-1
+    nb_neg = 0
+    DO i = 1,klon
+      IF (q(i,l)+d_q(i,l).LT.qmin) THEN
+      nb_neg = nb_neg + 1
+      d_q(i,l-1) = d_q(i,l-1) + (q(i,l)+d_q(i,l)-qmin) &
+            *(pres_h(i,l)-pres_h(i,l+1))/(pres_h(i,l-1)-pres_h(i,l))
+        d_q(i,l) = qmin - q(i,l)
+      ENDIF
+    ENDDO
+     ! IF (nb_neg.NE.0) THEN
+     ! PRINT *,'niveau ', l,' ' , nb_neg, ' valeurs negatives'
+     ! ENDIF
+  ENDDO
+  !
+  DO l = 1, klev-1
+    nb_neg = 0
+    DO i = 1,klon
+      IF (q(i,l)+d_q(i,l).LT.qmin) THEN
+      nb_neg = nb_neg + 1
+      d_q(i,l+1) = d_q(i,l+1) + (q(i,l)+d_q(i,l)-qmin) &
+            *(pres_h(i,l)-pres_h(i,l+1))/(pres_h(i,l+1)-pres_h(i,l+2))
+      d_q(i,l) = qmin - q(i,l)
+      ENDIF
+    ENDDO
+     ! IF (nb_neg.NE.0) THEN
+     ! PRINT *,'niveau ', l,' ' , nb_neg, ' valeurs negatives'
+     ! ENDIF
+  ENDDO
+  !
+  l = klev
+  DO i = 1,klon
+    IF (q(i,l)+d_q(i,l).LT.qmin) THEN
+      d_q(i,l) = qmin - q(i,l)
+    ENDIF
+  ENDDO
+  !
+  RETURN
+END SUBROUTINE tiedqneg

LMDZ6/trunk/libf/phylmd/Dust/trconvect.f90

-                      r5245
+                      r5246
 c Subroutine that computes the convective mixing and transport
+      SUBROUTINE trconvect(pplay,t_seri,pdtphys,pmfu,pmfd,pen_u,pde_u,
      .          pen_d,pde_d,paprs,zdz,xconv,qmin,qmax,lminmax,masse,
      .                                                dtrconv,tr_seri)
+! Subroutine that computes the convective mixing and transport
+SUBROUTINE trconvect(pplay,t_seri,pdtphys,pmfu,pmfd,pen_u,pde_u, &
+        pen_d,pde_d,paprs,zdz,xconv,qmin,qmax,lminmax,masse, &
+        dtrconv,tr_seri)
       USE dimphy
       USE infotrac
       USE indice_sol_mod
+  USE dimphy
+  USE infotrac
+  USE indice_sol_mod
       IMPLICIT NONE
+  IMPLICIT NONE
       INCLUDE "dimensions.h"
       INCLUDE "chem.h"
       INCLUDE "YOMCST.h"
       INCLUDE "paramet.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "chem.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "paramet.h"
 c============================= INPUT ===================================
       REAL qmin, qmax
       REAL xconv(nbtr), masse(nbtr)
       REAL pplay(klon,klev)    ! pression pour le mileu de chaque couche (en Pa)
       REAL t_seri(klon,klev)   ! temperature
       REAL zdz(klon,klev)      ! zdz
       REAL paprs(klon,klev+1)  ! pression pour chaque inter-couche (en Pa)
       REAL pmfu(klon,klev)     ! flux de masse dans le panache montant
       REAL pmfd(klon,klev)     ! flux de masse dans le panache descendant
       REAL pen_u(klon,klev)    ! flux entraine dans le panache montant
       REAL pde_u(klon,klev)    ! flux detraine dans le panache montant
       REAL pen_d(klon,klev)    ! flux entraine dans le panache descendant
       REAL pde_d(klon,klev)    ! flux detraine dans le panache descendant
       LOGICAL lminmax
       REAL pdtphys
 c============================= OUTPUT ==================================
       REAL aux_var1(klon,klev)
       REAL aux_var2(klon,klev)
       REAL tr_seri(klon,klev,nbtr) ! traceur
       REAL dtrconv(klon,nbtr) ! traceur
 c========================= LOCAL VARIABLES =============================
       INTEGER it, k, i, j
       REAL d_tr(klon,klev,nbtr)
+  !============================= INPUT ===================================
+  REAL :: qmin, qmax
+  REAL :: xconv(nbtr), masse(nbtr)
+  REAL :: pplay(klon,klev)    ! pression pour le mileu de chaque couche (en Pa)
+  REAL :: t_seri(klon,klev)   ! temperature
+  REAL :: zdz(klon,klev)      ! zdz
+  REAL :: paprs(klon,klev+1)  ! pression pour chaque inter-couche (en Pa)
+  REAL :: pmfu(klon,klev)     ! flux de masse dans le panache montant
+  REAL :: pmfd(klon,klev)     ! flux de masse dans le panache descendant
+  REAL :: pen_u(klon,klev)    ! flux entraine dans le panache montant
+  REAL :: pde_u(klon,klev)    ! flux detraine dans le panache montant
+  REAL :: pen_d(klon,klev)    ! flux entraine dans le panache descendant
+  REAL :: pde_d(klon,klev)    ! flux detraine dans le panache descendant
+  LOGICAL :: lminmax
+  REAL :: pdtphys
+  !============================= OUTPUT ==================================
+  REAL :: aux_var1(klon,klev)
+  REAL :: aux_var2(klon,klev)
+  REAL :: tr_seri(klon,klev,nbtr) ! traceur
+  REAL :: dtrconv(klon,nbtr) ! traceur
+  !========================= LOCAL VARIABLES =============================
+  INTEGER :: it, k, i, j
+  REAL :: d_tr(klon,klev,nbtr)
+      EXTERNAL nflxtr, tiedqneg, minmaxqfi
+      DO it=1, nbtr
+c
+      DO i=1, klon
+        dtrconv(i,it)=0.0
+      ENDDO
+      DO i=1,klon
+      DO j=1,klev
+        aux_var1(i,j)=tr_seri(i,j,it)
+        aux_var2(i,j)=d_tr(i,j,it)
+      ENDDO
+      ENDDO
+c
+cnhl      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+cnhl     .            pplay, paprs, tr_seri(1,1,it), d_tr(1,1,it) )
+      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .            pplay, paprs, aux_var1, aux_var2 )
+c
+      CALL tiedqneg(paprs,aux_var1, aux_var2)
+cnhl      CALL tiedqneg(paprs,tr_seri(1,1,it), d_tr(1,1,it))
+      DO i=1,klon
+      DO j=1,klev
+        tr_seri(i,j,it)=aux_var1(i,j)
+        d_tr(i,j,it)=aux_var2(i,j)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        IF (d_tr(i,k,it).LT.0.) THEN
+          tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr(i,k,it)
+        ELSE
+          tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr(i,k,it)*xconv(it)
+        ENDIF
+      ENDDO
+      ENDDO
+c
+cnhl      CALL kg_to_cm3(pplay,t_seri,d_tr(1,1,it))
+      CALL kg_to_cm3(pplay,t_seri,aux_var2)
+      DO i=1,klon
+      DO j=1,klev
+        d_tr(i,j,it)=aux_var2(i,j)
+      ENDDO
+      ENDDO
+  EXTERNAL nflxtr, tiedqneg, minmaxqfi
+      DO k = 1, klev
+      DO i = 1, klon
+        IF (d_tr(i,k,it).GE.0.) THEN
+        dtrconv(i,it)=dtrconv(i,it)+(1.-xconv(it))*d_tr(i,k,it)
+     .                /RNAVO*masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys
+        ENDIF
+      ENDDO
+      ENDDO
+  DO it=1, nbtr
+  !
+  DO i=1, klon
+    dtrconv(i,it)=0.0
+  ENDDO
+  DO i=1,klon
+  DO j=1,klev
+    aux_var1(i,j)=tr_seri(i,j,it)
+    aux_var2(i,j)=d_tr(i,j,it)
+  ENDDO
+  ENDDO
+      IF (lminmax) THEN
+        DO i=1,klon
+        DO j=1,klev
+          aux_var1(i,j)=tr_seri(i,j,it)
+        ENDDO
+        ENDDO
+        CALL minmaxqfi(aux_var1,qmin,qmax,'apr convection')
+cnhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'apr convection')
+        DO i=1,klon
+        DO j=1,klev
+          tr_seri(i,j,it)=aux_var1(i,j)
+        ENDDO
+        ENDDO
+      ENDIF
+c
+      ENDDO
+  !
+  !nhl      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+  !nhl     .            pplay, paprs, tr_seri(1,1,it), d_tr(1,1,it) )
+  CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
+        pplay, paprs, aux_var1, aux_var2 )
+  !
+  CALL tiedqneg(paprs,aux_var1, aux_var2)
+  !nhl      CALL tiedqneg(paprs,tr_seri(1,1,it), d_tr(1,1,it))
+  DO i=1,klon
+  DO j=1,klev
+    tr_seri(i,j,it)=aux_var1(i,j)
+    d_tr(i,j,it)=aux_var2(i,j)
+  ENDDO
+  ENDDO
+  !
+  DO k = 1, klev
+  DO i = 1, klon
+    IF (d_tr(i,k,it).LT.0.) THEN
+      tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr(i,k,it)
+    ELSE
+      tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr(i,k,it)*xconv(it)
+    ENDIF
+  ENDDO
+  ENDDO
+  !
+  !nhl      CALL kg_to_cm3(pplay,t_seri,d_tr(1,1,it))
+  CALL kg_to_cm3(pplay,t_seri,aux_var2)
+  DO i=1,klon
+  DO j=1,klev
+    d_tr(i,j,it)=aux_var2(i,j)
+  ENDDO
+  ENDDO
+      END
+  DO k = 1, klev
+  DO i = 1, klon
+    IF (d_tr(i,k,it).GE.0.) THEN
+    dtrconv(i,it)=dtrconv(i,it)+(1.-xconv(it))*d_tr(i,k,it) &
+          /RNAVO*masse(it)*1.e3*1.e6*zdz(i,k)/pdtphys
+    ENDIF
+  ENDDO
+  ENDDO
+  IF (lminmax) THEN
+    DO i=1,klon
+    DO j=1,klev
+      aux_var1(i,j)=tr_seri(i,j,it)
+    ENDDO
+    ENDDO
+    CALL minmaxqfi(aux_var1,qmin,qmax,'apr convection')
+  !nhl      CALL minmaxqfi(tr_seri(1,1,it),qmin,qmax,'apr convection')
+    DO i=1,klon
+    DO j=1,klev
+      tr_seri(i,j,it)=aux_var1(i,j)
+    ENDDO
+    ENDDO
+  ENDIF
+  !
+  ENDDO
+END SUBROUTINE trconvect

Context Navigation

Legend:

LMDZ6/trunk/libf/phylmd/Dust/aeropt_spl.f90

LMDZ6/trunk/libf/phylmd/Dust/bcscav_spl.f90

LMDZ6/trunk/libf/phylmd/Dust/bl_for_dms.f90

LMDZ6/trunk/libf/phylmd/Dust/blcloud_scav.f90

LMDZ6/trunk/libf/phylmd/Dust/blcloud_scav_lsc.f90

LMDZ6/trunk/libf/phylmd/Dust/cltrac_spl.f90

LMDZ6/trunk/libf/phylmd/Dust/cm3_to_kg.f90

LMDZ6/trunk/libf/phylmd/Dust/coarsemission.f90

LMDZ6/trunk/libf/phylmd/Dust/condsurfc.f90

LMDZ6/trunk/libf/phylmd/Dust/condsurfc_new.f90

LMDZ6/trunk/libf/phylmd/Dust/condsurfs.f90

LMDZ6/trunk/libf/phylmd/Dust/condsurfs_new.f90

LMDZ6/trunk/libf/phylmd/Dust/deposition.f90

LMDZ6/trunk/libf/phylmd/Dust/finemission.f90

LMDZ6/trunk/libf/phylmd/Dust/gastoparticle.f90

LMDZ6/trunk/libf/phylmd/Dust/incloud_scav.f90

LMDZ6/trunk/libf/phylmd/Dust/incloud_scav_lsc.f90

LMDZ6/trunk/libf/phylmd/Dust/inscav_spl.f90

LMDZ6/trunk/libf/phylmd/Dust/kg_to_cm3.f90

LMDZ6/trunk/libf/phylmd/Dust/minmaxqfi2.f90

LMDZ6/trunk/libf/phylmd/Dust/minmaxsource.f90

LMDZ6/trunk/libf/phylmd/Dust/neutral.f90

LMDZ6/trunk/libf/phylmd/Dust/nightingale.f90

LMDZ6/trunk/libf/phylmd/Dust/precuremission.f90

LMDZ6/trunk/libf/phylmd/Dust/read_dust.F90

LMDZ6/trunk/libf/phylmd/Dust/read_newemissions.f90

LMDZ6/trunk/libf/phylmd/Dust/read_vent.F90

LMDZ6/trunk/libf/phylmd/Dust/seasalt.f90

LMDZ6/trunk/libf/phylmd/Dust/sediment_mod.f90

LMDZ6/trunk/libf/phylmd/Dust/tiedqneg.f90

LMDZ6/trunk/libf/phylmd/Dust/trconvect.f90

Download in other formats: