Changeset 5104


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

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

Location:
LMDZ6/branches/Amaury_dev/libf
Files:
2 edited
25 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/misc/lmdz_cppkeys_wrapper.F90

    r5103 r5104  
    1919  IMPLICIT NONE; PRIVATE
    2020  PUBLIC nf90_format, CPPKEY_PHYS, CPPKEY_INCA, CPPKEY_STRATAER, CPPKEY_DUST, &
    21       CPPKEY_DEBUGIO, CPPKEY_INLANDSIS
     21      CPPKEY_DEBUGIO, CPPKEY_INLANDSIS, CPPKEY_OUTPUTPHYSSCM
    2222
    2323#ifdef NC_DOUBLE

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz1d.F90

    r5103 r5104  
    11! $Id$
    2 
    3 !#include "../dyn3d/mod_const_mpi.F90"
    4 !#include "../dyn3d_common/control_mod.F90"
    5 !#include "../dyn3d_common/infotrac.F90"
    6 !#include "../dyn3d_common/disvert.F90"
    7 
    82
    93PROGRAM lmdz1d
    104  USE ioipsl, ONLY: getin
     5  USE lmdz_scm, ONLY: scm
     6  USE lmdz_old_lmdz1d, ONLY: old_lmdz1d
    117  IMPLICIT NONE
    128
    … …  
    2016    CALL old_lmdz1d
    2117  ENDIF
    22 
    2318END
    2419
    2520
    26 include "1DUTILS.h"
    27 include "1Dconv.h"
    2821
    29 
    30 
    31 

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_1dutils.f90

    r5103 r5104  
    1 ! $Id$
    2 
    3 INCLUDE "conf_gcm.f90"
    4 
    5 SUBROUTINE conf_unicol
    6 
    7   use IOIPSL
    8   USE print_control_mod, ONLY: lunout
    9   IMPLICIT NONE
    10   !-----------------------------------------------------------------------
    11   !     Auteurs :   A. Lahellec  .
    12 
    13   !   Declarations :
    14   !   --------------
    15 
    16   include "compar1d.h"
    17   include "flux_arp.h"
    18   include "tsoilnudge.h"
    19   include "fcg_gcssold.h"
    20 #include "fcg_racmo.h"
    21   include "fcg_racmo.h"
    22 
    23 
    24   !   local:
    25   !   ------
    26 
    27   !      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
    28 
    29   !  -------------------------------------------------------------------
    30 
    31   !      .........    Initilisation parametres du lmdz1D      ..........
    32 
    33   !---------------------------------------------------------------------
    34   !   initialisations:
    35   !   ----------------
    36 
    37   !Config  Key  = lunout
    38   !Config  Desc = unite de fichier pour les impressions
    39   !Config  Def  = 6
    40   !Config  Help = unite de fichier pour les impressions
    41   !Config         (defaut sortie standard = 6)
    42   lunout = 6
    43   !      CALL getin('lunout', lunout)
    44   IF (lunout /= 5 .and. lunout /= 6) THEN
    45     OPEN(lunout, FILE = 'lmdz.out')
    46   ENDIF
    47 
    48   !Config  Key  = prt_level
    49   !Config  Desc = niveau d'impressions de debogage
    50   !Config  Def  = 0
    51   !Config  Help = Niveau d'impression pour le debogage
    52   !Config         (0 = minimum d'impression)
    53   !      prt_level = 0
    54   !      CALL getin('prt_level',prt_level)
    55 
    56   !-----------------------------------------------------------------------
    57   !  Parametres de controle du run:
    58   !-----------------------------------------------------------------------
    59 
    60   !Config  Key  = restart
    61   !Config  Desc = on repart des startphy et start1dyn
    62   !Config  Def  = false
    63   !Config  Help = les fichiers restart doivent etre renomme en start
    64   restart = .FALSE.
    65   CALL getin('restart', restart)
    66 
    67   !Config  Key  = forcing_type
    68   !Config  Desc = defines the way the SCM is forced:
    69   !Config  Def  = 0
    70   !!Config  Help = 0 ==> forcing_les = .TRUE.
    71   !             initial profiles from file prof.inp.001
    72   !             no forcing by LS convergence ;
    73   !             surface temperature imposed ;
    74   !             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
    75   !         = 1 ==> forcing_radconv = .TRUE.
    76   !             idem forcing_type = 0, but the imposed radiative cooling
    77   !             is set to 0 (hence, if iflag_radia=0 in physiq.def,
    78   !             then there is no radiative cooling at all)
    79   !         = 2 ==> forcing_toga = .TRUE.
    80   !             initial profiles from TOGA-COARE IFA files
    81   !             LS convergence and SST imposed from TOGA-COARE IFA files
    82   !         = 3 ==> forcing_GCM2SCM = .TRUE.
    83   !             initial profiles from the GCM output
    84   !             LS convergence imposed from the GCM output
    85   !         = 4 ==> forcing_twpi = .TRUE.
    86   !             initial profiles from TWPICE nc files
    87   !             LS convergence and SST imposed from TWPICE nc files
    88   !         = 5 ==> forcing_rico = .TRUE.
    89   !             initial profiles from RICO idealized
    90   !             LS convergence imposed from  RICO (cst)
    91   !         = 6 ==> forcing_amma = .TRUE.
    92   !         = 10 ==> forcing_case = .TRUE.
    93   !             initial profiles from case.nc file
    94   !         = 40 ==> forcing_GCSSold = .TRUE.
    95   !             initial profile from GCSS file
    96   !             LS convergence imposed from GCSS file
    97   !         = 50 ==> forcing_fire = .TRUE.
    98   !         = 59 ==> forcing_sandu = .TRUE.
    99   !             initial profiles from sanduref file: see prof.inp.001
    100   !             SST varying with time and divergence constante: see ifa_sanduref.txt file
    101   !             Radiation has to be computed interactively
    102   !         = 60 ==> forcing_astex = .TRUE.
    103   !             initial profiles from file: see prof.inp.001
    104   !             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
    105   !             Radiation has to be computed interactively
    106   !         = 61 ==> forcing_armcu = .TRUE.
    107   !             initial profiles from file: see prof.inp.001
    108   !             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
    109   !             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
    110   !             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s
    111   !             Radiation to be switched off
    112   !         > 100 ==> forcing_case = .TRUE. or forcing_case2 = .TRUE.
    113   !             initial profiles from case.nc file
    114 
    115   forcing_type = 0
    116   CALL getin('forcing_type', forcing_type)
    117   imp_fcg_gcssold = .FALSE.
    118   ts_fcg_gcssold = .FALSE.
    119   Tp_fcg_gcssold = .FALSE.
    120   Tp_ini_gcssold = .FALSE.
    121   xTurb_fcg_gcssold = .FALSE.
    122   IF (forcing_type ==40) THEN
    123     CALL getin('imp_fcg', imp_fcg_gcssold)
    124     CALL getin('ts_fcg', ts_fcg_gcssold)
    125     CALL getin('tp_fcg', Tp_fcg_gcssold)
    126     CALL getin('tp_ini', Tp_ini_gcssold)
    127     CALL getin('turb_fcg', xTurb_fcg_gcssold)
    128   ENDIF
    129 
    130   !Parametres de forcage
    131   !Config  Key  = tend_t
    132   !Config  Desc = forcage ou non par advection de T
    133   !Config  Def  = false
    134   !Config  Help = forcage ou non par advection de T
    135   tend_t = 0
    136   CALL getin('tend_t', tend_t)
    137 
    138   !Config  Key  = tend_q
    139   !Config  Desc = forcage ou non par advection de q
    140   !Config  Def  = false
    141   !Config  Help = forcage ou non par advection de q
    142   tend_q = 0
    143   CALL getin('tend_q', tend_q)
    144 
    145   !Config  Key  = tend_u
    146   !Config  Desc = forcage ou non par advection de u
    147   !Config  Def  = false
    148   !Config  Help = forcage ou non par advection de u
    149   tend_u = 0
    150   CALL getin('tend_u', tend_u)
    151 
    152   !Config  Key  = tend_v
    153   !Config  Desc = forcage ou non par advection de v
    154   !Config  Def  = false
    155   !Config  Help = forcage ou non par advection de v
    156   tend_v = 0
    157   CALL getin('tend_v', tend_v)
    158 
    159   !Config  Key  = tend_w
    160   !Config  Desc = forcage ou non par vitesse verticale
    161   !Config  Def  = false
    162   !Config  Help = forcage ou non par vitesse verticale
    163   tend_w = 0
    164   CALL getin('tend_w', tend_w)
    165 
    166   !Config  Key  = tend_rayo
    167   !Config  Desc = forcage ou non par dtrad
    168   !Config  Def  = false
    169   !Config  Help = forcage ou non par dtrad
    170   tend_rayo = 0
    171   CALL getin('tend_rayo', tend_rayo)
    172 
    173 
    174   !Config  Key  = nudge_t
    175   !Config  Desc = constante de nudging de T
    176   !Config  Def  = false
    177   !Config  Help = constante de nudging de T
    178   nudge_t = 0.
    179   CALL getin('nudge_t', nudge_t)
    180 
    181   !Config  Key  = nudge_q
    182   !Config  Desc = constante de nudging de q
    183   !Config  Def  = false
    184   !Config  Help = constante de nudging de q
    185   nudge_q = 0.
    186   CALL getin('nudge_q', nudge_q)
    187 
    188   !Config  Key  = nudge_u
    189   !Config  Desc = constante de nudging de u
    190   !Config  Def  = false
    191   !Config  Help = constante de nudging de u
    192   nudge_u = 0.
    193   CALL getin('nudge_u', nudge_u)
    194 
    195   !Config  Key  = nudge_v
    196   !Config  Desc = constante de nudging de v
    197   !Config  Def  = false
    198   !Config  Help = constante de nudging de v
    199   nudge_v = 0.
    200   CALL getin('nudge_v', nudge_v)
    201 
    202   !Config  Key  = nudge_w
    203   !Config  Desc = constante de nudging de w
    204   !Config  Def  = false
    205   !Config  Help = constante de nudging de w
    206   nudge_w = 0.
    207   CALL getin('nudge_w', nudge_w)
    208 
    209 
    210   !Config  Key  = iflag_nudge
    211   !Config  Desc = atmospheric nudging ttype (decimal code)
    212   !Config  Def  = 0
    213   !Config  Help = 0 ==> no nudging
    214   !  If digit number n of iflag_nudge is set, then nudging of type n is on
    215   !  If digit number n of iflag_nudge is not set, then nudging of type n is off
    216   !   (digits are numbered from the right)
    217   iflag_nudge = 0
    218   CALL getin('iflag_nudge', iflag_nudge)
    219 
    220   !Config  Key  = ok_flux_surf
    221   !Config  Desc = forcage ou non par les flux de surface
    222   !Config  Def  = false
    223   !Config  Help = forcage ou non par les flux de surface
    224   ok_flux_surf = .FALSE.
    225   CALL getin('ok_flux_surf', ok_flux_surf)
    226 
    227   !Config  Key  = ok_forc_tsurf
    228   !Config  Desc = forcage ou non par la Ts
    229   !Config  Def  = false
    230   !Config  Help = forcage ou non par la Ts
    231   ok_forc_tsurf = .FALSE.
    232   CALL getin('ok_forc_tsurf', ok_forc_tsurf)
    233 
    234   !Config  Key  = ok_prescr_ust
    235   !Config  Desc = ustar impose ou non
    236   !Config  Def  = false
    237   !Config  Help = ustar impose ou non
    238   ok_prescr_ust = .FALSE.
    239   CALL getin('ok_prescr_ust', ok_prescr_ust)
    240 
    241 
    242   !Config  Key  = ok_prescr_beta
    243   !Config  Desc = betaevap impose ou non
    244   !Config  Def  = false
    245   !Config  Help = betaevap impose ou non
    246   ok_prescr_beta = .FALSE.
    247   CALL getin('ok_prescr_beta', ok_prescr_beta)
    248 
    249   !Config  Key  = ok_old_disvert
    250   !Config  Desc = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
    251   !Config  Def  = false
    252   !Config  Help = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
    253   ok_old_disvert = .FALSE.
    254   CALL getin('ok_old_disvert', ok_old_disvert)
    255 
    256   !Config  Key  = time_ini
    257   !Config  Desc = meaningless in this  case
    258   !Config  Def  = 0.
    259   !Config  Help =
    260   time_ini = 0.
    261   CALL getin('time_ini', time_ini)
    262 
    263   !Config  Key  = rlat et rlon
    264   !Config  Desc = latitude et longitude
    265   !Config  Def  = 0.0  0.0
    266   !Config  Help = fixe la position de la colonne
    267   xlat = 0.
    268   xlon = 0.
    269   CALL getin('rlat', xlat)
    270   CALL getin('rlon', xlon)
    271 
    272   !Config  Key  = airephy
    273   !Config  Desc = Grid cell area
    274   !Config  Def  = 1.e11
    275   !Config  Help =
    276   airefi = 1.e11
    277   CALL getin('airephy', airefi)
    278 
    279   !Config  Key  = nat_surf
    280   !Config  Desc = surface type
    281   !Config  Def  = 0 (ocean)
    282   !Config  Help = 0=ocean,1=land,2=glacier,3=banquise
    283   nat_surf = 0.
    284   CALL getin('nat_surf', nat_surf)
    285 
    286   !Config  Key  = tsurf
    287   !Config  Desc = surface temperature
    288   !Config  Def  = 290.
    289   !Config  Help = surface temperature
    290   tsurf = 290.
    291   CALL getin('tsurf', tsurf)
    292 
    293   !Config  Key  = psurf
    294   !Config  Desc = surface pressure
    295   !Config  Def  = 102400.
    296   !Config  Help =
    297   psurf = 102400.
    298   CALL getin('psurf', psurf)
    299 
    300   !Config  Key  = zsurf
    301   !Config  Desc = surface altitude
    302   !Config  Def  = 0.
    303   !Config  Help =
    304   zsurf = 0.
    305   CALL getin('zsurf', zsurf)
    306   ! EV pour accord avec format standard
    307   CALL getin('zorog', zsurf)
    308 
    309 
    310   !Config  Key  = rugos
    311   !Config  Desc = coefficient de frottement
    312   !Config  Def  = 0.0001
    313   !Config  Help = calcul du Cdrag
    314   rugos = 0.0001
    315   CALL getin('rugos', rugos)
    316   ! FH/2020/04/08/confinement: Pour le nouveau format standard, la rugosite s'appelle z0
    317   CALL getin('z0', rugos)
    318 
    319   !Config  Key  = rugosh
    320   !Config  Desc = coefficient de frottement
    321   !Config  Def  = rugos
    322   !Config  Help = calcul du Cdrag
    323   rugosh = rugos
    324   CALL getin('rugosh', rugosh)
    325 
    326 
    327 
    328   !Config  Key  = snowmass
    329   !Config  Desc = mass de neige de la surface en kg/m2
    330   !Config  Def  = 0.0000
    331   !Config  Help = snowmass
    332   snowmass = 0.0000
    333   CALL getin('snowmass', snowmass)
    334 
    335   !Config  Key  = wtsurf et wqsurf
    336   !Config  Desc = ???
    337   !Config  Def  = 0.0 0.0
    338   !Config  Help =
    339   wtsurf = 0.0
    340   wqsurf = 0.0
    341   CALL getin('wtsurf', wtsurf)
    342   CALL getin('wqsurf', wqsurf)
    343 
    344   !Config  Key  = albedo
    345   !Config  Desc = albedo
    346   !Config  Def  = 0.09
    347   !Config  Help =
    348   albedo = 0.09
    349   CALL getin('albedo', albedo)
    350 
    351   !Config  Key  = agesno
    352   !Config  Desc = age de la neige
    353   !Config  Def  = 30.0
    354   !Config  Help =
    355   xagesno = 30.0
    356   CALL getin('agesno', xagesno)
    357 
    358   !Config  Key  = restart_runoff
    359   !Config  Desc = age de la neige
    360   !Config  Def  = 30.0
    361   !Config  Help =
    362   restart_runoff = 0.0
    363   CALL getin('restart_runoff', restart_runoff)
    364 
    365   !Config  Key  = qsolinp
    366   !Config  Desc = initial bucket water content (kg/m2) when land (5std)
    367   !Config  Def  = 30.0
    368   !Config  Help =
    369   qsolinp = 1.
    370   CALL getin('qsolinp', qsolinp)
    371 
    372 
    373 
    374   !Config  Key  = betaevap
    375   !Config  Desc = beta for actual evaporation when prescribed
    376   !Config  Def  = 1.0
    377   !Config  Help =
    378   betaevap = 1.
    379   CALL getin('betaevap', betaevap)
    380 
    381   !Config  Key  = zpicinp
    382   !Config  Desc = denivellation orographie
    383   !Config  Def  = 0.
    384   !Config  Help =  input brise
    385   zpicinp = 0.
    386   CALL getin('zpicinp', zpicinp)
    387   !Config key = nudge_tsoil
    388   !Config  Desc = activation of soil temperature nudging
    389   !Config  Def  = .FALSE.
    390   !Config  Help = ...
    391 
    392   nudge_tsoil = .FALSE.
    393   CALL getin('nudge_tsoil', nudge_tsoil)
    394 
    395   !Config key = isoil_nudge
    396   !Config  Desc = level number where soil temperature is nudged
    397   !Config  Def  = 3
    398   !Config  Help = ...
    399 
    400   isoil_nudge = 3
    401   CALL getin('isoil_nudge', isoil_nudge)
    402 
    403   !Config key = Tsoil_nudge
    404   !Config  Desc = target temperature for tsoil(isoil_nudge)
    405   !Config  Def  = 300.
    406   !Config  Help = ...
    407 
    408   Tsoil_nudge = 300.
    409   CALL getin('Tsoil_nudge', Tsoil_nudge)
    410 
    411   !Config key = tau_soil_nudge
    412   !Config  Desc = nudging relaxation time for tsoil
    413   !Config  Def  = 3600.
    414   !Config  Help = ...
    415 
    416   tau_soil_nudge = 3600.
    417   CALL getin('tau_soil_nudge', tau_soil_nudge)
    418 
    419   !----------------------------------------------------------
    420   ! Param??tres de for??age pour les forcages communs:
    421   ! Pour les forcages communs: ces entiers valent 0 ou 1
    422   ! tadv= advection tempe, tadvv= adv tempe verticale, tadvh= adv tempe horizontale
    423   ! qadv= advection q, qadvv= adv q verticale, qadvh= adv q horizontale
    424   ! trad= 0 (rayonnement actif) ou 1 (prescrit par tend_rad) ou adv (prescir et contenu dans les tadv)
    425   ! forcages en omega, w, vent geostrophique ou ustar
    426   ! Parametres de nudging en u,v,t,q valent 0 ou 1 ou le temps de nudging
    427   !----------------------------------------------------------
    428 
    429   !Config  Key  = tadv
    430   !Config  Desc = forcage ou non par advection totale de T
    431   !Config  Def  = false
    432   !Config  Help = forcage ou non par advection totale de T
    433   tadv = 0
    434   CALL getin('tadv', tadv)
    435 
    436   !Config  Key  = tadvv
    437   !Config  Desc = forcage ou non par advection verticale de T
    438   !Config  Def  = false
    439   !Config  Help = forcage ou non par advection verticale de T
    440   tadvv = 0
    441   CALL getin('tadvv', tadvv)
    442 
    443   !Config  Key  = tadvh
    444   !Config  Desc = forcage ou non par advection horizontale de T
    445   !Config  Def  = false
    446   !Config  Help = forcage ou non par advection horizontale de T
    447   tadvh = 0
    448   CALL getin('tadvh', tadvh)
    449 
    450   !Config  Key  = thadv
    451   !Config  Desc = forcage ou non par advection totale de Theta
    452   !Config  Def  = false
    453   !Config  Help = forcage ou non par advection totale de Theta
    454   thadv = 0
    455   CALL getin('thadv', thadv)
    456 
    457   !Config  Key  = thadvv
    458   !Config  Desc = forcage ou non par advection verticale de Theta
    459   !Config  Def  = false
    460   !Config  Help = forcage ou non par advection verticale de Theta
    461   thadvv = 0
    462   CALL getin('thadvv', thadvv)
    463 
    464   !Config  Key  = thadvh
    465   !Config  Desc = forcage ou non par advection horizontale de Theta
    466   !Config  Def  = false
    467   !Config  Help = forcage ou non par advection horizontale de Theta
    468   thadvh = 0
    469   CALL getin('thadvh', thadvh)
    470 
    471   !Config  Key  = qadv
    472   !Config  Desc = forcage ou non par advection totale de Q
    473   !Config  Def  = false
    474   !Config  Help = forcage ou non par advection totale de Q
    475   qadv = 0
    476   CALL getin('qadv', qadv)
    477 
    478   !Config  Key  = qadvv
    479   !Config  Desc = forcage ou non par advection verticale de Q
    480   !Config  Def  = false
    481   !Config  Help = forcage ou non par advection verticale de Q
    482   qadvv = 0
    483   CALL getin('qadvv', qadvv)
    484 
    485   !Config  Key  = qadvh
    486   !Config  Desc = forcage ou non par advection horizontale de Q
    487   !Config  Def  = false
    488   !Config  Help = forcage ou non par advection horizontale de Q
    489   qadvh = 0
    490   CALL getin('qadvh', qadvh)
    491 
    492   !Config  Key  = trad
    493   !Config  Desc = forcage ou non par tendance radiative
    494   !Config  Def  = false
    495   !Config  Help = forcage ou non par tendance radiative
    496   trad = 0
    497   CALL getin('trad', trad)
    498 
    499   !Config  Key  = forc_omega
    500   !Config  Desc = forcage ou non par omega
    501   !Config  Def  = false
    502   !Config  Help = forcage ou non par omega
    503   forc_omega = 0
    504   CALL getin('forc_omega', forc_omega)
    505 
    506   !Config  Key  = forc_u
    507   !Config  Desc = forcage ou non par u
    508   !Config  Def  = false
    509   !Config  Help = forcage ou non par u
    510   forc_u = 0
    511   CALL getin('forc_u', forc_u)
    512 
    513   !Config  Key  = forc_v
    514   !Config  Desc = forcage ou non par v
    515   !Config  Def  = false
    516   !Config  Help = forcage ou non par v
    517   forc_v = 0
    518   CALL getin('forc_v', forc_v)
    519   !Config  Key  = forc_w
    520   !Config  Desc = forcage ou non par w
    521   !Config  Def  = false
    522   !Config  Help = forcage ou non par w
    523   forc_w = 0
    524   CALL getin('forc_w', forc_w)
    525 
    526   !Config  Key  = forc_geo
    527   !Config  Desc = forcage ou non par geo
    528   !Config  Def  = false
    529   !Config  Help = forcage ou non par geo
    530   forc_geo = 0
    531   CALL getin('forc_geo', forc_geo)
    532 
    533   ! Meme chose que ok_precr_ust
    534   !Config  Key  = forc_ustar
    535   !Config  Desc = forcage ou non par ustar
    536   !Config  Def  = false
    537   !Config  Help = forcage ou non par ustar
    538   forc_ustar = 0
    539   CALL getin('forc_ustar', forc_ustar)
    540   IF (forc_ustar == 1) ok_prescr_ust = .TRUE.
    541 
    542 
    543   !Config  Key  = nudging_u
    544   !Config  Desc = forcage ou non par nudging sur u
    545   !Config  Def  = false
    546   !Config  Help = forcage ou non par nudging sur u
    547   nudging_u = 0
    548   CALL getin('nudging_u', nudging_u)
    549 
    550   !Config  Key  = nudging_v
    551   !Config  Desc = forcage ou non par nudging sur v
    552   !Config  Def  = false
    553   !Config  Help = forcage ou non par nudging sur v
    554   nudging_v = 0
    555   CALL getin('nudging_v', nudging_v)
    556 
    557   !Config  Key  = nudging_w
    558   !Config  Desc = forcage ou non par nudging sur w
    559   !Config  Def  = false
    560   !Config  Help = forcage ou non par nudging sur w
    561   nudging_w = 0
    562   CALL getin('nudging_w', nudging_w)
    563 
    564   ! RELIQUE ANCIENS FORMAT. ECRASE PAR LE SUIVANT
    565   !Config  Key  = nudging_q
    566   !Config  Desc = forcage ou non par nudging sur q
    567   !Config  Def  = false
    568   !Config  Help = forcage ou non par nudging sur q
    569   nudging_qv = 0
    570   CALL getin('nudging_q', nudging_qv)
    571   CALL getin('nudging_qv', nudging_qv)
    572 
    573   p_nudging_u = 11000.
    574   p_nudging_v = 11000.
    575   p_nudging_t = 11000.
    576   p_nudging_qv = 11000.
    577   CALL getin('p_nudging_u', p_nudging_u)
    578   CALL getin('p_nudging_v', p_nudging_v)
    579   CALL getin('p_nudging_t', p_nudging_t)
    580   CALL getin('p_nudging_qv', p_nudging_qv)
    581 
    582   !Config  Key  = nudging_t
    583   !Config  Desc = forcage ou non par nudging sur t
    584   !Config  Def  = false
    585   !Config  Help = forcage ou non par nudging sur t
    586   nudging_t = 0
    587   CALL getin('nudging_t', nudging_t)
    588 
    589   write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
    590   write(lunout, *)' Configuration des parametres du gcm1D: '
    591   write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
    592   write(lunout, *)' restart = ', restart
    593   write(lunout, *)' forcing_type = ', forcing_type
    594   write(lunout, *)' time_ini = ', time_ini
    595   write(lunout, *)' rlat = ', xlat
    596   write(lunout, *)' rlon = ', xlon
    597   write(lunout, *)' airephy = ', airefi
    598   write(lunout, *)' nat_surf = ', nat_surf
    599   write(lunout, *)' tsurf = ', tsurf
    600   write(lunout, *)' psurf = ', psurf
    601   write(lunout, *)' zsurf = ', zsurf
    602   write(lunout, *)' rugos = ', rugos
    603   write(lunout, *)' snowmass=', snowmass
    604   write(lunout, *)' wtsurf = ', wtsurf
    605   write(lunout, *)' wqsurf = ', wqsurf
    606   write(lunout, *)' albedo = ', albedo
    607   write(lunout, *)' xagesno = ', xagesno
    608   write(lunout, *)' restart_runoff = ', restart_runoff
    609   write(lunout, *)' qsolinp = ', qsolinp
    610   write(lunout, *)' zpicinp = ', zpicinp
    611   write(lunout, *)' nudge_tsoil = ', nudge_tsoil
    612   write(lunout, *)' isoil_nudge = ', isoil_nudge
    613   write(lunout, *)' Tsoil_nudge = ', Tsoil_nudge
    614   write(lunout, *)' tau_soil_nudge = ', tau_soil_nudge
    615   write(lunout, *)' tadv =      ', tadv
    616   write(lunout, *)' tadvv =     ', tadvv
    617   write(lunout, *)' tadvh =     ', tadvh
    618   write(lunout, *)' thadv =     ', thadv
    619   write(lunout, *)' thadvv =    ', thadvv
    620   write(lunout, *)' thadvh =    ', thadvh
    621   write(lunout, *)' qadv =      ', qadv
    622   write(lunout, *)' qadvv =     ', qadvv
    623   write(lunout, *)' qadvh =     ', qadvh
    624   write(lunout, *)' trad =      ', trad
    625   write(lunout, *)' forc_omega = ', forc_omega
    626   write(lunout, *)' forc_w     = ', forc_w
    627   write(lunout, *)' forc_geo   = ', forc_geo
    628   write(lunout, *)' forc_ustar = ', forc_ustar
    629   write(lunout, *)' nudging_u  = ', nudging_u
    630   write(lunout, *)' nudging_v  = ', nudging_v
    631   write(lunout, *)' nudging_t  = ', nudging_t
    632   write(lunout, *)' nudging_qv  = ', nudging_qv
    633   IF (forcing_type ==40) THEN
    634     write(lunout, *) '--- Forcing type GCSS Old --- with:'
    635     write(lunout, *)'imp_fcg', imp_fcg_gcssold
    636     write(lunout, *)'ts_fcg', ts_fcg_gcssold
    637     write(lunout, *)'tp_fcg', Tp_fcg_gcssold
    638     write(lunout, *)'tp_ini', Tp_ini_gcssold
    639     write(lunout, *)'xturb_fcg', xTurb_fcg_gcssold
    640   ENDIF
    641 
    642   write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
    643   write(lunout, *)
    644 
    645   RETURN
    646 END
    647 
    648 ! $Id: dyn1deta0.F 1279 2010/07/30 A Lahellec$
    649 
    650 
    651 SUBROUTINE dyn1deta0(fichnom, plev, play, phi, phis, presnivs, &
    652         &                          ucov, vcov, temp, q, omega2)
    653   USE dimphy
    654   USE mod_grid_phy_lmdz
    655   USE mod_phys_lmdz_para
    656   USE iophy
    657   USE phys_state_var_mod
    658   USE iostart
    659   USE write_field_phy
    660   USE infotrac
    661   use control_mod
    662   USE comconst_mod, ONLY: im, jm, lllm
    663   USE logic_mod, ONLY: fxyhypb, ysinus
    664   USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn
    665   USE netcdf, ONLY: nf90_open, nf90_write, nf90_noerr
    666 
    667   IMPLICIT NONE
    668   !=======================================================
    669   ! Ecriture du fichier de redemarrage sous format NetCDF
    670   !=======================================================
    671   !   Declarations:
    672   !   -------------
    673   include "dimensions.h"
    674   !!#include "control.h"
    675 
    676   !   Arguments:
    677   !   ----------
    678   CHARACTER*(*) fichnom
    679   !Al1 plev tronque pour .nc mais plev(klev+1):=0
    680   real :: plev(klon, klev + 1), play (klon, klev), phi(klon, klev)
    681   real :: presnivs(klon, klev)
    682   real :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
    683   real :: q(klon, klev, nqtot), omega2(klon, klev)
    684   !      real :: ug(klev),vg(klev),fcoriolis
    685   real :: phis(klon)
    686 
    687   !   Variables locales pour NetCDF:
    688   !   ------------------------------
    689   INTEGER iq
    690   INTEGER length
    691   PARAMETER (length = 100)
    692   REAL tab_cntrl(length) ! tableau des parametres du run
    693   character*4 nmq(nqtot)
    694   character*12 modname
    695   character*80 abort_message
    696   LOGICAL found
    697 
    698   modname = 'dyn1deta0 : '
    699   !!      nmq(1)="vap"
    700   !!      nmq(2)="cond"
    701   !!      do iq=3,nqtot
    702   !!        write(nmq(iq),'("tra",i1)') iq-2
    703   !!      enddo
    704   DO iq = 1, nqtot
    705     nmq(iq) = trim(tracers(iq)%name)
    706   ENDDO
    707   PRINT*, 'in dyn1deta0 ', fichnom, klon, klev, nqtot
    708   CALL open_startphy(fichnom)
    709   PRINT*, 'after open startphy ', fichnom, nmq
    710 
    711   ! Lecture des parametres de controle:
    712 
    713   CALL get_var("controle", tab_cntrl)
    714 
    715   im = tab_cntrl(1)
    716   jm = tab_cntrl(2)
    717   lllm = tab_cntrl(3)
    718   day_ref = tab_cntrl(4)
    719   annee_ref = tab_cntrl(5)
    720   !      rad        = tab_cntrl(6)
    721   !      omeg       = tab_cntrl(7)
    722   !      g          = tab_cntrl(8)
    723   !      cpp        = tab_cntrl(9)
    724   !      kappa      = tab_cntrl(10)
    725   !      daysec     = tab_cntrl(11)
    726   !      dtvr       = tab_cntrl(12)
    727   !      etot0      = tab_cntrl(13)
    728   !      ptot0      = tab_cntrl(14)
    729   !      ztot0      = tab_cntrl(15)
    730   !      stot0      = tab_cntrl(16)
    731   !      ang0       = tab_cntrl(17)
    732   !      pa         = tab_cntrl(18)
    733   !      preff      = tab_cntrl(19)
    734 
    735   !      clon       = tab_cntrl(20)
    736   !      clat       = tab_cntrl(21)
    737   !      grossismx  = tab_cntrl(22)
    738   !      grossismy  = tab_cntrl(23)
    739 
    740   IF (tab_cntrl(24)==1.)  THEN
    741     fxyhypb = .TRUE.
    742     !        dzoomx   = tab_cntrl(25)
    743     !        dzoomy   = tab_cntrl(26)
    744     !        taux     = tab_cntrl(28)
    745     !        tauy     = tab_cntrl(29)
    746   ELSE
    747     fxyhypb = .FALSE.
    748     ysinus = .FALSE.
    749     IF(tab_cntrl(27)==1.) ysinus = .TRUE.
    750   ENDIF
    751 
    752   day_ini = tab_cntrl(30)
    753   itau_dyn = tab_cntrl(31)
    754   !   .................................................................
    755 
    756 
    757   !      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
    758   !Al1
    759   Print*, 'day_ref,annee_ref,day_ini,itau_dyn', &
    760           &              day_ref, annee_ref, day_ini, itau_dyn
    761 
    762   !  Lecture des champs
    763 
    764   CALL get_field("play", play, found)
    765   IF (.NOT. found) PRINT*, modname // 'Le champ <Play> est absent'
    766   CALL get_field("phi", phi, found)
    767   IF (.NOT. found) PRINT*, modname // 'Le champ <Phi> est absent'
    768   CALL get_field("phis", phis, found)
    769   IF (.NOT. found) PRINT*, modname // 'Le champ <Phis> est absent'
    770   CALL get_field("presnivs", presnivs, found)
    771   IF (.NOT. found) PRINT*, modname // 'Le champ <Presnivs> est absent'
    772   CALL get_field("ucov", ucov, found)
    773   IF (.NOT. found) PRINT*, modname // 'Le champ <ucov> est absent'
    774   CALL get_field("vcov", vcov, found)
    775   IF (.NOT. found) PRINT*, modname // 'Le champ <vcov> est absent'
    776   CALL get_field("temp", temp, found)
    777   IF (.NOT. found) PRINT*, modname // 'Le champ <temp> est absent'
    778   CALL get_field("omega2", omega2, found)
    779   IF (.NOT. found) PRINT*, modname // 'Le champ <omega2> est absent'
    780   plev(1, klev + 1) = 0.
    781   CALL get_field("plev", plev(:, 1:klev), found)
    782   IF (.NOT. found) PRINT*, modname // 'Le champ <Plev> est absent'
    783 
    784   Do iq = 1, nqtot
    785     CALL get_field("q" // nmq(iq), q(:, :, iq), found)
    786     IF (.NOT.found)PRINT*, modname // 'Le champ <q' // nmq // '> est absent'
    787   EndDo
    788 
    789   CALL close_startphy
    790   PRINT*, ' close startphy', fichnom, play(1, 1), play(1, klev), temp(1, klev)
    791 
    792   RETURN
    793 END
    794 
    795 ! $Id: dyn1dredem.F 1279 2010/07/29 A Lahellec$
    796 
    797 
    798 SUBROUTINE dyn1dredem(fichnom, plev, play, phi, phis, presnivs, &
    799         &                          ucov, vcov, temp, q, omega2)
    800   USE dimphy
    801   USE mod_grid_phy_lmdz
    802   USE mod_phys_lmdz_para
    803   USE phys_state_var_mod
    804   USE iostart
    805   USE infotrac
    806   use control_mod
    807   USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
    808   USE logic_mod, ONLY: fxyhypb, ysinus
    809   USE temps_mod, ONLY: annee_ref, day_end, day_ref, itau_dyn, itaufin
    810   USE netcdf, ONLY: nf90_open, nf90_write, nf90_noerr
    811 
    812   IMPLICIT NONE
    813   !=======================================================
    814   ! Ecriture du fichier de redemarrage sous format NetCDF
    815   !=======================================================
    816   !   Declarations:
    817   !   -------------
    818   include "dimensions.h"
    819   !!#include "control.h"
    820 
    821   !   Arguments:
    822   !   ----------
    823   CHARACTER*(*) fichnom
    824   !Al1 plev tronque pour .nc mais plev(klev+1):=0
    825   real :: plev(klon, klev), play (klon, klev), phi(klon, klev)
    826   real :: presnivs(klon, klev)
    827   real :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
    828   real :: q(klon, klev, nqtot)
    829   real :: omega2(klon, klev), rho(klon, klev + 1)
    830   !      real :: ug(klev),vg(klev),fcoriolis
    831   real :: phis(klon)
    832 
    833   !   Variables locales pour NetCDF:
    834   !   ------------------------------
    835   INTEGER nid
    836   INTEGER ierr
    837   INTEGER iq, l
    838   INTEGER length
    839   PARAMETER (length = 100)
    840   REAL tab_cntrl(length) ! tableau des parametres du run
    841   character*4 nmq(nqtot)
    842   character*20 modname
    843   character*80 abort_message
    844 
    845   INTEGER pass
    846 
    847   CALL open_restartphy(fichnom)
    848   PRINT*, 'redm1 ', fichnom, klon, klev, nqtot
    849   !!      nmq(1)="vap"
    850   !!      nmq(2)="cond"
    851   !!      nmq(3)="tra1"
    852   !!      nmq(4)="tra2"
    853   DO iq = 1, nqtot
    854     nmq(iq) = trim(tracers(iq)%name)
    855   ENDDO
    856 
    857   !     modname = 'dyn1dredem'
    858   !     ierr = nf90_open(fichnom, nf90_write, nid)
    859   !     IF (ierr .NE. nf90_noerr) THEN
    860   !        abort_message="Pb. d ouverture "//fichnom
    861   !        CALL abort_gcm('Modele 1D',abort_message,1)
    862   !     ENDIF
    863 
    864   DO l = 1, length
    865     tab_cntrl(l) = 0.
    866   ENDDO
    867   tab_cntrl(1) = FLOAT(iim)
    868   tab_cntrl(2) = FLOAT(jjm)
    869   tab_cntrl(3) = FLOAT(llm)
    870   tab_cntrl(4) = FLOAT(day_ref)
    871   tab_cntrl(5) = FLOAT(annee_ref)
    872   tab_cntrl(6) = rad
    873   tab_cntrl(7) = omeg
    874   tab_cntrl(8) = g
    875   tab_cntrl(9) = cpp
    876   tab_cntrl(10) = kappa
    877   tab_cntrl(11) = daysec
    878   tab_cntrl(12) = dtvr
    879   !       tab_cntrl(13) = etot0
    880   !       tab_cntrl(14) = ptot0
    881   !       tab_cntrl(15) = ztot0
    882   !       tab_cntrl(16) = stot0
    883   !       tab_cntrl(17) = ang0
    884   !       tab_cntrl(18) = pa
    885   !       tab_cntrl(19) = preff
    886 
    887   !    .....    parametres  pour le zoom      ......
    888 
    889   !       tab_cntrl(20)  = clon
    890   !       tab_cntrl(21)  = clat
    891   !       tab_cntrl(22)  = grossismx
    892   !       tab_cntrl(23)  = grossismy
    893 
    894   IF (fxyhypb)   THEN
    895     tab_cntrl(24) = 1.
    896     !       tab_cntrl(25) = dzoomx
    897     !       tab_cntrl(26) = dzoomy
    898     tab_cntrl(27) = 0.
    899     !       tab_cntrl(28) = taux
    900     !       tab_cntrl(29) = tauy
    901   ELSE
    902     tab_cntrl(24) = 0.
    903     !       tab_cntrl(25) = dzoomx
    904     !       tab_cntrl(26) = dzoomy
    905     tab_cntrl(27) = 0.
    906     tab_cntrl(28) = 0.
    907     tab_cntrl(29) = 0.
    908     IF(ysinus)  tab_cntrl(27) = 1.
    909   ENDIF
    910   !Al1 iday_end -> day_end
    911   tab_cntrl(30) = FLOAT(day_end)
    912   tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
    913 
    914   DO pass = 1, 2
    915     CALL put_var(pass, "controle", "Param. de controle Dyn1D", tab_cntrl)
    916 
    917     !  Ecriture/extension de la coordonnee temps
    918 
    919 
    920     !  Ecriture des champs
    921 
    922     CALL put_field(pass, "plev", "p interfaces sauf la nulle", plev)
    923     CALL put_field(pass, "play", "", play)
    924     CALL put_field(pass, "phi", "geopotentielle", phi)
    925     CALL put_field(pass, "phis", "geopotentiell de surface", phis)
    926     CALL put_field(pass, "presnivs", "", presnivs)
    927     CALL put_field(pass, "ucov", "", ucov)
    928     CALL put_field(pass, "vcov", "", vcov)
    929     CALL put_field(pass, "temp", "", temp)
    930     CALL put_field(pass, "omega2", "", omega2)
     1MODULE lmdz_1dutils
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC fq_sat, conf_unicol, dyn1deta0, dyn1dredem, gr_fi_dyn, abort_gcm, gr_dyn_fi, &
     4          disvert0, advect_vert, advect_va, lstendh, nudge_rht_init, nudge_uv_init, &
     5          nudge_rht, nudge_uv, interp2_case_vertical
     6CONTAINS
     7  REAL FUNCTION fq_sat(kelvin, millibar)
     8    IMPLICIT none
     9    !======================================================================
     10    ! Autheur(s): Z.X. Li (LMD/CNRS)
     11    ! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
     12    !======================================================================
     13    ! Arguments:
     14    ! kelvin---input-R: temperature en Kelvin
     15    ! millibar--input-R: pression en mb
     16
     17    ! fq_sat----output-R: vapeur d'eau saturante en kg/kg
     18    !======================================================================
     19
     20    REAL, INTENT(IN) :: kelvin, millibar
     21
     22    REAL r2es
     23    PARAMETER (r2es = 611.14 * 18.0153 / 28.9644)
     24    REAL r3les, r3ies, r3es
     25    PARAMETER (R3LES = 17.269)
     26    PARAMETER (R3IES = 21.875)
     27
     28    REAL r4les, r4ies, r4es
     29    PARAMETER (R4LES = 35.86)
     30    PARAMETER (R4IES = 7.66)
     31
     32    REAL rtt
     33    PARAMETER (rtt = 273.16)
     34
     35    REAL retv
     36    PARAMETER (retv = 28.9644 / 18.0153 - 1.0)
     37
     38    REAL zqsat
     39    REAL temp, pres
     40    !     ------------------------------------------------------------------
     41
     42    temp = kelvin
     43    pres = millibar * 100.0
     44    !      write(*,*)'kelvin,millibar=',kelvin,millibar
     45    !      write(*,*)'temp,pres=',temp,pres
     46
     47    IF (temp <= rtt) THEN
     48      r3es = r3ies
     49      r4es = r4ies
     50    ELSE
     51      r3es = r3les
     52      r4es = r4les
     53    ENDIF
     54
     55    zqsat = r2es / pres * EXP (r3es * (temp - rtt) / (temp - r4es))
     56    zqsat = MIN(0.5, ZQSAT)
     57    zqsat = zqsat / (1. - retv * zqsat)
     58
     59    fq_sat = zqsat
     60  END FUNCTION fq_sat
     61
     62  SUBROUTINE conf_unicol
     63
     64    use IOIPSL
     65    USE print_control_mod, ONLY: lunout
     66    !-----------------------------------------------------------------------
     67    !     Auteurs :   A. Lahellec  .
     68
     69    !   Declarations :
     70    !   --------------
     71
     72    include "compar1d.h"
     73    include "flux_arp.h"
     74    include "tsoilnudge.h"
     75    include "fcg_gcssold.h"
     76    include "fcg_racmo.h"
     77
     78
     79    !   local:
     80    !   ------
     81
     82    !      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
     83
     84    !  -------------------------------------------------------------------
     85
     86    !      .........    Initilisation parametres du lmdz1D      ..........
     87
     88    !---------------------------------------------------------------------
     89    !   initialisations:
     90    !   ----------------
     91
     92    !Config  Key  = lunout
     93    !Config  Desc = unite de fichier pour les impressions
     94    !Config  Def  = 6
     95    !Config  Help = unite de fichier pour les impressions
     96    !Config         (defaut sortie standard = 6)
     97    lunout = 6
     98    !      CALL getin('lunout', lunout)
     99    IF (lunout /= 5 .and. lunout /= 6) THEN
     100      OPEN(lunout, FILE = 'lmdz.out')
     101    ENDIF
     102
     103    !Config  Key  = prt_level
     104    !Config  Desc = niveau d'impressions de debogage
     105    !Config  Def  = 0
     106    !Config  Help = Niveau d'impression pour le debogage
     107    !Config         (0 = minimum d'impression)
     108    !      prt_level = 0
     109    !      CALL getin('prt_level',prt_level)
     110
     111    !-----------------------------------------------------------------------
     112    !  Parametres de controle du run:
     113    !-----------------------------------------------------------------------
     114
     115    !Config  Key  = restart
     116    !Config  Desc = on repart des startphy et start1dyn
     117    !Config  Def  = false
     118    !Config  Help = les fichiers restart doivent etre renomme en start
     119    restart = .FALSE.
     120    CALL getin('restart', restart)
     121
     122    !Config  Key  = forcing_type
     123    !Config  Desc = defines the way the SCM is forced:
     124    !Config  Def  = 0
     125    !!Config  Help = 0 ==> forcing_les = .TRUE.
     126    !             initial profiles from file prof.inp.001
     127    !             no forcing by LS convergence ;
     128    !             surface temperature imposed ;
     129    !             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
     130    !         = 1 ==> forcing_radconv = .TRUE.
     131    !             idem forcing_type = 0, but the imposed radiative cooling
     132    !             is set to 0 (hence, if iflag_radia=0 in physiq.def,
     133    !             then there is no radiative cooling at all)
     134    !         = 2 ==> forcing_toga = .TRUE.
     135    !             initial profiles from TOGA-COARE IFA files
     136    !             LS convergence and SST imposed from TOGA-COARE IFA files
     137    !         = 3 ==> forcing_GCM2SCM = .TRUE.
     138    !             initial profiles from the GCM output
     139    !             LS convergence imposed from the GCM output
     140    !         = 4 ==> forcing_twpi = .TRUE.
     141    !             initial profiles from TWPICE nc files
     142    !             LS convergence and SST imposed from TWPICE nc files
     143    !         = 5 ==> forcing_rico = .TRUE.
     144    !             initial profiles from RICO idealized
     145    !             LS convergence imposed from  RICO (cst)
     146    !         = 6 ==> forcing_amma = .TRUE.
     147    !         = 10 ==> forcing_case = .TRUE.
     148    !             initial profiles from case.nc file
     149    !         = 40 ==> forcing_GCSSold = .TRUE.
     150    !             initial profile from GCSS file
     151    !             LS convergence imposed from GCSS file
     152    !         = 50 ==> forcing_fire = .TRUE.
     153    !         = 59 ==> forcing_sandu = .TRUE.
     154    !             initial profiles from sanduref file: see prof.inp.001
     155    !             SST varying with time and divergence constante: see ifa_sanduref.txt file
     156    !             Radiation has to be computed interactively
     157    !         = 60 ==> forcing_astex = .TRUE.
     158    !             initial profiles from file: see prof.inp.001
     159    !             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
     160    !             Radiation has to be computed interactively
     161    !         = 61 ==> forcing_armcu = .TRUE.
     162    !             initial profiles from file: see prof.inp.001
     163    !             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
     164    !             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
     165    !             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s
     166    !             Radiation to be switched off
     167    !         > 100 ==> forcing_case = .TRUE. or forcing_case2 = .TRUE.
     168    !             initial profiles from case.nc file
     169
     170    forcing_type = 0
     171    CALL getin('forcing_type', forcing_type)
     172    imp_fcg_gcssold = .FALSE.
     173    ts_fcg_gcssold = .FALSE.
     174    Tp_fcg_gcssold = .FALSE.
     175    Tp_ini_gcssold = .FALSE.
     176    xTurb_fcg_gcssold = .FALSE.
     177    IF (forcing_type ==40) THEN
     178      CALL getin('imp_fcg', imp_fcg_gcssold)
     179      CALL getin('ts_fcg', ts_fcg_gcssold)
     180      CALL getin('tp_fcg', Tp_fcg_gcssold)
     181      CALL getin('tp_ini', Tp_ini_gcssold)
     182      CALL getin('turb_fcg', xTurb_fcg_gcssold)
     183    ENDIF
     184
     185    !Parametres de forcage
     186    !Config  Key  = tend_t
     187    !Config  Desc = forcage ou non par advection de T
     188    !Config  Def  = false
     189    !Config  Help = forcage ou non par advection de T
     190    tend_t = 0
     191    CALL getin('tend_t', tend_t)
     192
     193    !Config  Key  = tend_q
     194    !Config  Desc = forcage ou non par advection de q
     195    !Config  Def  = false
     196    !Config  Help = forcage ou non par advection de q
     197    tend_q = 0
     198    CALL getin('tend_q', tend_q)
     199
     200    !Config  Key  = tend_u
     201    !Config  Desc = forcage ou non par advection de u
     202    !Config  Def  = false
     203    !Config  Help = forcage ou non par advection de u
     204    tend_u = 0
     205    CALL getin('tend_u', tend_u)
     206
     207    !Config  Key  = tend_v
     208    !Config  Desc = forcage ou non par advection de v
     209    !Config  Def  = false
     210    !Config  Help = forcage ou non par advection de v
     211    tend_v = 0
     212    CALL getin('tend_v', tend_v)
     213
     214    !Config  Key  = tend_w
     215    !Config  Desc = forcage ou non par vitesse verticale
     216    !Config  Def  = false
     217    !Config  Help = forcage ou non par vitesse verticale
     218    tend_w = 0
     219    CALL getin('tend_w', tend_w)
     220
     221    !Config  Key  = tend_rayo
     222    !Config  Desc = forcage ou non par dtrad
     223    !Config  Def  = false
     224    !Config  Help = forcage ou non par dtrad
     225    tend_rayo = 0
     226    CALL getin('tend_rayo', tend_rayo)
     227
     228
     229    !Config  Key  = nudge_t
     230    !Config  Desc = constante de nudging de T
     231    !Config  Def  = false
     232    !Config  Help = constante de nudging de T
     233    nudge_t = 0.
     234    CALL getin('nudge_t', nudge_t)
     235
     236    !Config  Key  = nudge_q
     237    !Config  Desc = constante de nudging de q
     238    !Config  Def  = false
     239    !Config  Help = constante de nudging de q
     240    nudge_q = 0.
     241    CALL getin('nudge_q', nudge_q)
     242
     243    !Config  Key  = nudge_u
     244    !Config  Desc = constante de nudging de u
     245    !Config  Def  = false
     246    !Config  Help = constante de nudging de u
     247    nudge_u = 0.
     248    CALL getin('nudge_u', nudge_u)
     249
     250    !Config  Key  = nudge_v
     251    !Config  Desc = constante de nudging de v
     252    !Config  Def  = false
     253    !Config  Help = constante de nudging de v
     254    nudge_v = 0.
     255    CALL getin('nudge_v', nudge_v)
     256
     257    !Config  Key  = nudge_w
     258    !Config  Desc = constante de nudging de w
     259    !Config  Def  = false
     260    !Config  Help = constante de nudging de w
     261    nudge_w = 0.
     262    CALL getin('nudge_w', nudge_w)
     263
     264
     265    !Config  Key  = iflag_nudge
     266    !Config  Desc = atmospheric nudging ttype (decimal code)
     267    !Config  Def  = 0
     268    !Config  Help = 0 ==> no nudging
     269    !  If digit number n of iflag_nudge is set, then nudging of type n is on
     270    !  If digit number n of iflag_nudge is not set, then nudging of type n is off
     271    !   (digits are numbered from the right)
     272    iflag_nudge = 0
     273    CALL getin('iflag_nudge', iflag_nudge)
     274
     275    !Config  Key  = ok_flux_surf
     276    !Config  Desc = forcage ou non par les flux de surface
     277    !Config  Def  = false
     278    !Config  Help = forcage ou non par les flux de surface
     279    ok_flux_surf = .FALSE.
     280    CALL getin('ok_flux_surf', ok_flux_surf)
     281
     282    !Config  Key  = ok_forc_tsurf
     283    !Config  Desc = forcage ou non par la Ts
     284    !Config  Def  = false
     285    !Config  Help = forcage ou non par la Ts
     286    ok_forc_tsurf = .FALSE.
     287    CALL getin('ok_forc_tsurf', ok_forc_tsurf)
     288
     289    !Config  Key  = ok_prescr_ust
     290    !Config  Desc = ustar impose ou non
     291    !Config  Def  = false
     292    !Config  Help = ustar impose ou non
     293    ok_prescr_ust = .FALSE.
     294    CALL getin('ok_prescr_ust', ok_prescr_ust)
     295
     296
     297    !Config  Key  = ok_prescr_beta
     298    !Config  Desc = betaevap impose ou non
     299    !Config  Def  = false
     300    !Config  Help = betaevap impose ou non
     301    ok_prescr_beta = .FALSE.
     302    CALL getin('ok_prescr_beta', ok_prescr_beta)
     303
     304    !Config  Key  = ok_old_disvert
     305    !Config  Desc = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
     306    !Config  Def  = false
     307    !Config  Help = utilisation de l ancien programme disvert0 (dans 1DUTILS.h)
     308    ok_old_disvert = .FALSE.
     309    CALL getin('ok_old_disvert', ok_old_disvert)
     310
     311    !Config  Key  = time_ini
     312    !Config  Desc = meaningless in this  case
     313    !Config  Def  = 0.
     314    !Config  Help =
     315    time_ini = 0.
     316    CALL getin('time_ini', time_ini)
     317
     318    !Config  Key  = rlat et rlon
     319    !Config  Desc = latitude et longitude
     320    !Config  Def  = 0.0  0.0
     321    !Config  Help = fixe la position de la colonne
     322    xlat = 0.
     323    xlon = 0.
     324    CALL getin('rlat', xlat)
     325    CALL getin('rlon', xlon)
     326
     327    !Config  Key  = airephy
     328    !Config  Desc = Grid cell area
     329    !Config  Def  = 1.e11
     330    !Config  Help =
     331    airefi = 1.e11
     332    CALL getin('airephy', airefi)
     333
     334    !Config  Key  = nat_surf
     335    !Config  Desc = surface type
     336    !Config  Def  = 0 (ocean)
     337    !Config  Help = 0=ocean,1=land,2=glacier,3=banquise
     338    nat_surf = 0.
     339    CALL getin('nat_surf', nat_surf)
     340
     341    !Config  Key  = tsurf
     342    !Config  Desc = surface temperature
     343    !Config  Def  = 290.
     344    !Config  Help = surface temperature
     345    tsurf = 290.
     346    CALL getin('tsurf', tsurf)
     347
     348    !Config  Key  = psurf
     349    !Config  Desc = surface pressure
     350    !Config  Def  = 102400.
     351    !Config  Help =
     352    psurf = 102400.
     353    CALL getin('psurf', psurf)
     354
     355    !Config  Key  = zsurf
     356    !Config  Desc = surface altitude
     357    !Config  Def  = 0.
     358    !Config  Help =
     359    zsurf = 0.
     360    CALL getin('zsurf', zsurf)
     361    ! EV pour accord avec format standard
     362    CALL getin('zorog', zsurf)
     363
     364
     365    !Config  Key  = rugos
     366    !Config  Desc = coefficient de frottement
     367    !Config  Def  = 0.0001
     368    !Config  Help = calcul du Cdrag
     369    rugos = 0.0001
     370    CALL getin('rugos', rugos)
     371    ! FH/2020/04/08/confinement: Pour le nouveau format standard, la rugosite s'appelle z0
     372    CALL getin('z0', rugos)
     373
     374    !Config  Key  = rugosh
     375    !Config  Desc = coefficient de frottement
     376    !Config  Def  = rugos
     377    !Config  Help = calcul du Cdrag
     378    rugosh = rugos
     379    CALL getin('rugosh', rugosh)
     380
     381
     382
     383    !Config  Key  = snowmass
     384    !Config  Desc = mass de neige de la surface en kg/m2
     385    !Config  Def  = 0.0000
     386    !Config  Help = snowmass
     387    snowmass = 0.0000
     388    CALL getin('snowmass', snowmass)
     389
     390    !Config  Key  = wtsurf et wqsurf
     391    !Config  Desc = ???
     392    !Config  Def  = 0.0 0.0
     393    !Config  Help =
     394    wtsurf = 0.0
     395    wqsurf = 0.0
     396    CALL getin('wtsurf', wtsurf)
     397    CALL getin('wqsurf', wqsurf)
     398
     399    !Config  Key  = albedo
     400    !Config  Desc = albedo
     401    !Config  Def  = 0.09
     402    !Config  Help =
     403    albedo = 0.09
     404    CALL getin('albedo', albedo)
     405
     406    !Config  Key  = agesno
     407    !Config  Desc = age de la neige
     408    !Config  Def  = 30.0
     409    !Config  Help =
     410    xagesno = 30.0
     411    CALL getin('agesno', xagesno)
     412
     413    !Config  Key  = restart_runoff
     414    !Config  Desc = age de la neige
     415    !Config  Def  = 30.0
     416    !Config  Help =
     417    restart_runoff = 0.0
     418    CALL getin('restart_runoff', restart_runoff)
     419
     420    !Config  Key  = qsolinp
     421    !Config  Desc = initial bucket water content (kg/m2) when land (5std)
     422    !Config  Def  = 30.0
     423    !Config  Help =
     424    qsolinp = 1.
     425    CALL getin('qsolinp', qsolinp)
     426
     427
     428
     429    !Config  Key  = betaevap
     430    !Config  Desc = beta for actual evaporation when prescribed
     431    !Config  Def  = 1.0
     432    !Config  Help =
     433    betaevap = 1.
     434    CALL getin('betaevap', betaevap)
     435
     436    !Config  Key  = zpicinp
     437    !Config  Desc = denivellation orographie
     438    !Config  Def  = 0.
     439    !Config  Help =  input brise
     440    zpicinp = 0.
     441    CALL getin('zpicinp', zpicinp)
     442    !Config key = nudge_tsoil
     443    !Config  Desc = activation of soil temperature nudging
     444    !Config  Def  = .FALSE.
     445    !Config  Help = ...
     446
     447    nudge_tsoil = .FALSE.
     448    CALL getin('nudge_tsoil', nudge_tsoil)
     449
     450    !Config key = isoil_nudge
     451    !Config  Desc = level number where soil temperature is nudged
     452    !Config  Def  = 3
     453    !Config  Help = ...
     454
     455    isoil_nudge = 3
     456    CALL getin('isoil_nudge', isoil_nudge)
     457
     458    !Config key = Tsoil_nudge
     459    !Config  Desc = target temperature for tsoil(isoil_nudge)
     460    !Config  Def  = 300.
     461    !Config  Help = ...
     462
     463    Tsoil_nudge = 300.
     464    CALL getin('Tsoil_nudge', Tsoil_nudge)
     465
     466    !Config key = tau_soil_nudge
     467    !Config  Desc = nudging relaxation time for tsoil
     468    !Config  Def  = 3600.
     469    !Config  Help = ...
     470
     471    tau_soil_nudge = 3600.
     472    CALL getin('tau_soil_nudge', tau_soil_nudge)
     473
     474    !----------------------------------------------------------
     475    ! Param??tres de for??age pour les forcages communs:
     476    ! Pour les forcages communs: ces entiers valent 0 ou 1
     477    ! tadv= advection tempe, tadvv= adv tempe verticale, tadvh= adv tempe horizontale
     478    ! qadv= advection q, qadvv= adv q verticale, qadvh= adv q horizontale
     479    ! trad= 0 (rayonnement actif) ou 1 (prescrit par tend_rad) ou adv (prescir et contenu dans les tadv)
     480    ! forcages en omega, w, vent geostrophique ou ustar
     481    ! Parametres de nudging en u,v,t,q valent 0 ou 1 ou le temps de nudging
     482    !----------------------------------------------------------
     483
     484    !Config  Key  = tadv
     485    !Config  Desc = forcage ou non par advection totale de T
     486    !Config  Def  = false
     487    !Config  Help = forcage ou non par advection totale de T
     488    tadv = 0
     489    CALL getin('tadv', tadv)
     490
     491    !Config  Key  = tadvv
     492    !Config  Desc = forcage ou non par advection verticale de T
     493    !Config  Def  = false
     494    !Config  Help = forcage ou non par advection verticale de T
     495    tadvv = 0
     496    CALL getin('tadvv', tadvv)
     497
     498    !Config  Key  = tadvh
     499    !Config  Desc = forcage ou non par advection horizontale de T
     500    !Config  Def  = false
     501    !Config  Help = forcage ou non par advection horizontale de T
     502    tadvh = 0
     503    CALL getin('tadvh', tadvh)
     504
     505    !Config  Key  = thadv
     506    !Config  Desc = forcage ou non par advection totale de Theta
     507    !Config  Def  = false
     508    !Config  Help = forcage ou non par advection totale de Theta
     509    thadv = 0
     510    CALL getin('thadv', thadv)
     511
     512    !Config  Key  = thadvv
     513    !Config  Desc = forcage ou non par advection verticale de Theta
     514    !Config  Def  = false
     515    !Config  Help = forcage ou non par advection verticale de Theta
     516    thadvv = 0
     517    CALL getin('thadvv', thadvv)
     518
     519    !Config  Key  = thadvh
     520    !Config  Desc = forcage ou non par advection horizontale de Theta
     521    !Config  Def  = false
     522    !Config  Help = forcage ou non par advection horizontale de Theta
     523    thadvh = 0
     524    CALL getin('thadvh', thadvh)
     525
     526    !Config  Key  = qadv
     527    !Config  Desc = forcage ou non par advection totale de Q
     528    !Config  Def  = false
     529    !Config  Help = forcage ou non par advection totale de Q
     530    qadv = 0
     531    CALL getin('qadv', qadv)
     532
     533    !Config  Key  = qadvv
     534    !Config  Desc = forcage ou non par advection verticale de Q
     535    !Config  Def  = false
     536    !Config  Help = forcage ou non par advection verticale de Q
     537    qadvv = 0
     538    CALL getin('qadvv', qadvv)
     539
     540    !Config  Key  = qadvh
     541    !Config  Desc = forcage ou non par advection horizontale de Q
     542    !Config  Def  = false
     543    !Config  Help = forcage ou non par advection horizontale de Q
     544    qadvh = 0
     545    CALL getin('qadvh', qadvh)
     546
     547    !Config  Key  = trad
     548    !Config  Desc = forcage ou non par tendance radiative
     549    !Config  Def  = false
     550    !Config  Help = forcage ou non par tendance radiative
     551    trad = 0
     552    CALL getin('trad', trad)
     553
     554    !Config  Key  = forc_omega
     555    !Config  Desc = forcage ou non par omega
     556    !Config  Def  = false
     557    !Config  Help = forcage ou non par omega
     558    forc_omega = 0
     559    CALL getin('forc_omega', forc_omega)
     560
     561    !Config  Key  = forc_u
     562    !Config  Desc = forcage ou non par u
     563    !Config  Def  = false
     564    !Config  Help = forcage ou non par u
     565    forc_u = 0
     566    CALL getin('forc_u', forc_u)
     567
     568    !Config  Key  = forc_v
     569    !Config  Desc = forcage ou non par v
     570    !Config  Def  = false
     571    !Config  Help = forcage ou non par v
     572    forc_v = 0
     573    CALL getin('forc_v', forc_v)
     574    !Config  Key  = forc_w
     575    !Config  Desc = forcage ou non par w
     576    !Config  Def  = false
     577    !Config  Help = forcage ou non par w
     578    forc_w = 0
     579    CALL getin('forc_w', forc_w)
     580
     581    !Config  Key  = forc_geo
     582    !Config  Desc = forcage ou non par geo
     583    !Config  Def  = false
     584    !Config  Help = forcage ou non par geo
     585    forc_geo = 0
     586    CALL getin('forc_geo', forc_geo)
     587
     588    ! Meme chose que ok_precr_ust
     589    !Config  Key  = forc_ustar
     590    !Config  Desc = forcage ou non par ustar
     591    !Config  Def  = false
     592    !Config  Help = forcage ou non par ustar
     593    forc_ustar = 0
     594    CALL getin('forc_ustar', forc_ustar)
     595    IF (forc_ustar == 1) ok_prescr_ust = .TRUE.
     596
     597
     598    !Config  Key  = nudging_u
     599    !Config  Desc = forcage ou non par nudging sur u
     600    !Config  Def  = false
     601    !Config  Help = forcage ou non par nudging sur u
     602    nudging_u = 0
     603    CALL getin('nudging_u', nudging_u)
     604
     605    !Config  Key  = nudging_v
     606    !Config  Desc = forcage ou non par nudging sur v
     607    !Config  Def  = false
     608    !Config  Help = forcage ou non par nudging sur v
     609    nudging_v = 0
     610    CALL getin('nudging_v', nudging_v)
     611
     612    !Config  Key  = nudging_w
     613    !Config  Desc = forcage ou non par nudging sur w
     614    !Config  Def  = false
     615    !Config  Help = forcage ou non par nudging sur w
     616    nudging_w = 0
     617    CALL getin('nudging_w', nudging_w)
     618
     619    ! RELIQUE ANCIENS FORMAT. ECRASE PAR LE SUIVANT
     620    !Config  Key  = nudging_q
     621    !Config  Desc = forcage ou non par nudging sur q
     622    !Config  Def  = false
     623    !Config  Help = forcage ou non par nudging sur q
     624    nudging_qv = 0
     625    CALL getin('nudging_q', nudging_qv)
     626    CALL getin('nudging_qv', nudging_qv)
     627
     628    p_nudging_u = 11000.
     629    p_nudging_v = 11000.
     630    p_nudging_t = 11000.
     631    p_nudging_qv = 11000.
     632    CALL getin('p_nudging_u', p_nudging_u)
     633    CALL getin('p_nudging_v', p_nudging_v)
     634    CALL getin('p_nudging_t', p_nudging_t)
     635    CALL getin('p_nudging_qv', p_nudging_qv)
     636
     637    !Config  Key  = nudging_t
     638    !Config  Desc = forcage ou non par nudging sur t
     639    !Config  Def  = false
     640    !Config  Help = forcage ou non par nudging sur t
     641    nudging_t = 0
     642    CALL getin('nudging_t', nudging_t)
     643
     644    write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
     645    write(lunout, *)' Configuration des parametres du gcm1D: '
     646    write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
     647    write(lunout, *)' restart = ', restart
     648    write(lunout, *)' forcing_type = ', forcing_type
     649    write(lunout, *)' time_ini = ', time_ini
     650    write(lunout, *)' rlat = ', xlat
     651    write(lunout, *)' rlon = ', xlon
     652    write(lunout, *)' airephy = ', airefi
     653    write(lunout, *)' nat_surf = ', nat_surf
     654    write(lunout, *)' tsurf = ', tsurf
     655    write(lunout, *)' psurf = ', psurf
     656    write(lunout, *)' zsurf = ', zsurf
     657    write(lunout, *)' rugos = ', rugos
     658    write(lunout, *)' snowmass=', snowmass
     659    write(lunout, *)' wtsurf = ', wtsurf
     660    write(lunout, *)' wqsurf = ', wqsurf
     661    write(lunout, *)' albedo = ', albedo
     662    write(lunout, *)' xagesno = ', xagesno
     663    write(lunout, *)' restart_runoff = ', restart_runoff
     664    write(lunout, *)' qsolinp = ', qsolinp
     665    write(lunout, *)' zpicinp = ', zpicinp
     666    write(lunout, *)' nudge_tsoil = ', nudge_tsoil
     667    write(lunout, *)' isoil_nudge = ', isoil_nudge
     668    write(lunout, *)' Tsoil_nudge = ', Tsoil_nudge
     669    write(lunout, *)' tau_soil_nudge = ', tau_soil_nudge
     670    write(lunout, *)' tadv =      ', tadv
     671    write(lunout, *)' tadvv =     ', tadvv
     672    write(lunout, *)' tadvh =     ', tadvh
     673    write(lunout, *)' thadv =     ', thadv
     674    write(lunout, *)' thadvv =    ', thadvv
     675    write(lunout, *)' thadvh =    ', thadvh
     676    write(lunout, *)' qadv =      ', qadv
     677    write(lunout, *)' qadvv =     ', qadvv
     678    write(lunout, *)' qadvh =     ', qadvh
     679    write(lunout, *)' trad =      ', trad
     680    write(lunout, *)' forc_omega = ', forc_omega
     681    write(lunout, *)' forc_w     = ', forc_w
     682    write(lunout, *)' forc_geo   = ', forc_geo
     683    write(lunout, *)' forc_ustar = ', forc_ustar
     684    write(lunout, *)' nudging_u  = ', nudging_u
     685    write(lunout, *)' nudging_v  = ', nudging_v
     686    write(lunout, *)' nudging_t  = ', nudging_t
     687    write(lunout, *)' nudging_qv  = ', nudging_qv
     688    IF (forcing_type ==40) THEN
     689      write(lunout, *) '--- Forcing type GCSS Old --- with:'
     690      write(lunout, *)'imp_fcg', imp_fcg_gcssold
     691      write(lunout, *)'ts_fcg', ts_fcg_gcssold
     692      write(lunout, *)'tp_fcg', Tp_fcg_gcssold
     693      write(lunout, *)'tp_ini', Tp_ini_gcssold
     694      write(lunout, *)'xturb_fcg', xTurb_fcg_gcssold
     695    ENDIF
     696
     697    write(lunout, *)' +++++++++++++++++++++++++++++++++++++++'
     698    write(lunout, *)
     699
     700  END SUBROUTINE conf_unicol
     701
     702
     703  SUBROUTINE dyn1deta0(fichnom, plev, play, phi, phis, presnivs, &
     704          &                          ucov, vcov, temp, q, omega2)
     705    USE dimphy
     706    USE mod_grid_phy_lmdz
     707    USE mod_phys_lmdz_para
     708    USE iophy
     709    USE phys_state_var_mod
     710    USE iostart
     711    USE write_field_phy
     712    USE infotrac
     713    use control_mod
     714    USE comconst_mod, ONLY: im, jm, lllm
     715    USE logic_mod, ONLY: fxyhypb, ysinus
     716    USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn
     717    USE netcdf, ONLY: nf90_open, nf90_write, nf90_noerr
     718
     719    IMPLICIT NONE
     720    !=======================================================
     721    ! Ecriture du fichier de redemarrage sous format NetCDF
     722    !=======================================================
     723    !   Declarations:
     724    !   -------------
     725    include "dimensions.h"
     726
     727    !   Arguments:
     728    !   ----------
     729    CHARACTER*(*) fichnom
     730    !Al1 plev tronque pour .nc mais plev(klev+1):=0
     731    real :: plev(klon, klev + 1), play (klon, klev), phi(klon, klev)
     732    real :: presnivs(klon, klev)
     733    real :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
     734    real :: q(klon, klev, nqtot), omega2(klon, klev)
     735    !      real :: ug(klev),vg(klev),fcoriolis
     736    real :: phis(klon)
     737
     738    !   Variables locales pour NetCDF:
     739    !   ------------------------------
     740    INTEGER iq
     741    INTEGER length
     742    PARAMETER (length = 100)
     743    REAL tab_cntrl(length) ! tableau des parametres du run
     744    character*4 nmq(nqtot)
     745    character*12 modname
     746    character*80 abort_message
     747    LOGICAL found
     748
     749    modname = 'dyn1deta0 : '
     750    !!      nmq(1)="vap"
     751    !!      nmq(2)="cond"
     752    !!      do iq=3,nqtot
     753    !!        write(nmq(iq),'("tra",i1)') iq-2
     754    !!      enddo
     755    DO iq = 1, nqtot
     756      nmq(iq) = trim(tracers(iq)%name)
     757    ENDDO
     758    PRINT*, 'in dyn1deta0 ', fichnom, klon, klev, nqtot
     759    CALL open_startphy(fichnom)
     760    PRINT*, 'after open startphy ', fichnom, nmq
     761
     762    ! Lecture des parametres de controle:
     763    CALL get_var("controle", tab_cntrl)
     764
     765    im = tab_cntrl(1)
     766    jm = tab_cntrl(2)
     767    lllm = tab_cntrl(3)
     768    day_ref = tab_cntrl(4)
     769    annee_ref = tab_cntrl(5)
     770    !      rad        = tab_cntrl(6)
     771    !      omeg       = tab_cntrl(7)
     772    !      g          = tab_cntrl(8)
     773    !      cpp        = tab_cntrl(9)
     774    !      kappa      = tab_cntrl(10)
     775    !      daysec     = tab_cntrl(11)
     776    !      dtvr       = tab_cntrl(12)
     777    !      etot0      = tab_cntrl(13)
     778    !      ptot0      = tab_cntrl(14)
     779    !      ztot0      = tab_cntrl(15)
     780    !      stot0      = tab_cntrl(16)
     781    !      ang0       = tab_cntrl(17)
     782    !      pa         = tab_cntrl(18)
     783    !      preff      = tab_cntrl(19)
     784
     785    !      clon       = tab_cntrl(20)
     786    !      clat       = tab_cntrl(21)
     787    !      grossismx  = tab_cntrl(22)
     788    !      grossismy  = tab_cntrl(23)
     789
     790    IF (tab_cntrl(24)==1.)  THEN
     791      fxyhypb = .TRUE.
     792      !        dzoomx   = tab_cntrl(25)
     793      !        dzoomy   = tab_cntrl(26)
     794      !        taux     = tab_cntrl(28)
     795      !        tauy     = tab_cntrl(29)
     796    ELSE
     797      fxyhypb = .FALSE.
     798      ysinus = .FALSE.
     799      IF(tab_cntrl(27)==1.) ysinus = .TRUE.
     800    ENDIF
     801
     802    day_ini = tab_cntrl(30)
     803    itau_dyn = tab_cntrl(31)
     804
     805    Print*, 'day_ref,annee_ref,day_ini,itau_dyn', day_ref, annee_ref, day_ini, itau_dyn
     806
     807    !  Lecture des champs
     808    CALL get_field("play", play, found)
     809    IF (.NOT. found) PRINT*, modname // 'Le champ <Play> est absent'
     810    CALL get_field("phi", phi, found)
     811    IF (.NOT. found) PRINT*, modname // 'Le champ <Phi> est absent'
     812    CALL get_field("phis", phis, found)
     813    IF (.NOT. found) PRINT*, modname // 'Le champ <Phis> est absent'
     814    CALL get_field("presnivs", presnivs, found)
     815    IF (.NOT. found) PRINT*, modname // 'Le champ <Presnivs> est absent'
     816    CALL get_field("ucov", ucov, found)
     817    IF (.NOT. found) PRINT*, modname // 'Le champ <ucov> est absent'
     818    CALL get_field("vcov", vcov, found)
     819    IF (.NOT. found) PRINT*, modname // 'Le champ <vcov> est absent'
     820    CALL get_field("temp", temp, found)
     821    IF (.NOT. found) PRINT*, modname // 'Le champ <temp> est absent'
     822    CALL get_field("omega2", omega2, found)
     823    IF (.NOT. found) PRINT*, modname // 'Le champ <omega2> est absent'
     824    plev(1, klev + 1) = 0.
     825    CALL get_field("plev", plev(:, 1:klev), found)
     826    IF (.NOT. found) PRINT*, modname // 'Le champ <Plev> est absent'
    931827
    932828    Do iq = 1, nqtot
    933       CALL put_field(pass, "q" // nmq(iq), "eau vap ou condens et traceurs", &
    934               &                                                      q(:, :, iq))
     829      CALL get_field("q" // nmq(iq), q(:, :, iq), found)
     830      IF (.NOT.found)PRINT*, modname // 'Le champ <q' // nmq // '> est absent'
    935831    EndDo
    936     IF (pass==1) CALL enddef_restartphy
    937     IF (pass==2) CALL close_restartphy
    938 
    939   ENDDO
    940 
    941   RETURN
    942 END
    943 SUBROUTINE gr_fi_dyn(nfield, ngrid, im, jm, pfi, pdyn)
    944   IMPLICIT NONE
    945   !=======================================================================
    946   !   passage d'un champ de la grille scalaire a la grille physique
    947   !=======================================================================
    948 
    949   !-----------------------------------------------------------------------
    950   !   declarations:
    951   !   -------------
    952 
    953   INTEGER im, jm, ngrid, nfield
    954   REAL pdyn(im, jm, nfield)
    955   REAL pfi(ngrid, nfield)
    956 
    957   INTEGER i, j, ifield, ig
    958 
    959   !-----------------------------------------------------------------------
    960   !   calcul:
    961   !   -------
    962 
    963   DO ifield = 1, nfield
     832
     833    CALL close_startphy
     834    PRINT*, ' close startphy', fichnom, play(1, 1), play(1, klev), temp(1, klev)
     835  END SUBROUTINE dyn1deta0
     836
     837
     838  SUBROUTINE dyn1dredem(fichnom, plev, play, phi, phis, presnivs, &
     839          &                          ucov, vcov, temp, q, omega2)
     840    USE dimphy
     841    USE mod_grid_phy_lmdz
     842    USE mod_phys_lmdz_para
     843    USE phys_state_var_mod
     844    USE iostart
     845    USE infotrac
     846    use control_mod
     847    USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
     848    USE logic_mod, ONLY: fxyhypb, ysinus
     849    USE temps_mod, ONLY: annee_ref, day_end, day_ref, itau_dyn, itaufin
     850    USE netcdf, ONLY: nf90_open, nf90_write, nf90_noerr
     851
     852    IMPLICIT NONE
     853    !=======================================================
     854    ! Ecriture du fichier de redemarrage sous format NetCDF
     855    !=======================================================
     856    !   Declarations:
     857    !   -------------
     858    include "dimensions.h"
     859
     860    !   Arguments:
     861    !   ----------
     862    CHARACTER*(*) fichnom
     863    !Al1 plev tronque pour .nc mais plev(klev+1):=0
     864    real :: plev(klon, klev), play (klon, klev), phi(klon, klev)
     865    real :: presnivs(klon, klev)
     866    real :: ucov(klon, klev), vcov(klon, klev), temp(klon, klev)
     867    real :: q(klon, klev, nqtot)
     868    real :: omega2(klon, klev), rho(klon, klev + 1)
     869    !      real :: ug(klev),vg(klev),fcoriolis
     870    real :: phis(klon)
     871
     872    !   Variables locales pour NetCDF:
     873    !   ------------------------------
     874    INTEGER nid
     875    INTEGER ierr
     876    INTEGER iq, l
     877    INTEGER length
     878    PARAMETER (length = 100)
     879    REAL tab_cntrl(length) ! tableau des parametres du run
     880    character*4 nmq(nqtot)
     881    character*20 modname
     882    character*80 abort_message
     883
     884    INTEGER pass
     885
     886    CALL open_restartphy(fichnom)
     887    PRINT*, 'redm1 ', fichnom, klon, klev, nqtot
     888    !!      nmq(1)="vap"
     889    !!      nmq(2)="cond"
     890    !!      nmq(3)="tra1"
     891    !!      nmq(4)="tra2"
     892    DO iq = 1, nqtot
     893      nmq(iq) = trim(tracers(iq)%name)
     894    ENDDO
     895
     896    !     modname = 'dyn1dredem'
     897    !     ierr = nf90_open(fichnom, nf90_write, nid)
     898    !     IF (ierr .NE. nf90_noerr) THEN
     899    !        abort_message="Pb. d ouverture "//fichnom
     900    !        CALL abort_gcm('Modele 1D',abort_message,1)
     901    !     ENDIF
     902
     903    DO l = 1, length
     904      tab_cntrl(l) = 0.
     905    ENDDO
     906    tab_cntrl(1) = FLOAT(iim)
     907    tab_cntrl(2) = FLOAT(jjm)
     908    tab_cntrl(3) = FLOAT(llm)
     909    tab_cntrl(4) = FLOAT(day_ref)
     910    tab_cntrl(5) = FLOAT(annee_ref)
     911    tab_cntrl(6) = rad
     912    tab_cntrl(7) = omeg
     913    tab_cntrl(8) = g
     914    tab_cntrl(9) = cpp
     915    tab_cntrl(10) = kappa
     916    tab_cntrl(11) = daysec
     917    tab_cntrl(12) = dtvr
     918    !       tab_cntrl(13) = etot0
     919    !       tab_cntrl(14) = ptot0
     920    !       tab_cntrl(15) = ztot0
     921    !       tab_cntrl(16) = stot0
     922    !       tab_cntrl(17) = ang0
     923    !       tab_cntrl(18) = pa
     924    !       tab_cntrl(19) = preff
     925
     926    !    .....    parametres  pour le zoom      ......
     927
     928    !       tab_cntrl(20)  = clon
     929    !       tab_cntrl(21)  = clat
     930    !       tab_cntrl(22)  = grossismx
     931    !       tab_cntrl(23)  = grossismy
     932
     933    IF (fxyhypb)   THEN
     934      tab_cntrl(24) = 1.
     935      !       tab_cntrl(25) = dzoomx
     936      !       tab_cntrl(26) = dzoomy
     937      tab_cntrl(27) = 0.
     938      !       tab_cntrl(28) = taux
     939      !       tab_cntrl(29) = tauy
     940    ELSE
     941      tab_cntrl(24) = 0.
     942      !       tab_cntrl(25) = dzoomx
     943      !       tab_cntrl(26) = dzoomy
     944      tab_cntrl(27) = 0.
     945      tab_cntrl(28) = 0.
     946      tab_cntrl(29) = 0.
     947      IF(ysinus)  tab_cntrl(27) = 1.
     948    ENDIF
     949    !Al1 iday_end -> day_end
     950    tab_cntrl(30) = FLOAT(day_end)
     951    tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
     952
     953    DO pass = 1, 2
     954      CALL put_var(pass, "controle", "Param. de controle Dyn1D", tab_cntrl)
     955
     956      !  Ecriture/extension de la coordonnee temps
     957
     958
     959      !  Ecriture des champs
     960
     961      CALL put_field(pass, "plev", "p interfaces sauf la nulle", plev)
     962      CALL put_field(pass, "play", "", play)
     963      CALL put_field(pass, "phi", "geopotentielle", phi)
     964      CALL put_field(pass, "phis", "geopotentiell de surface", phis)
     965      CALL put_field(pass, "presnivs", "", presnivs)
     966      CALL put_field(pass, "ucov", "", ucov)
     967      CALL put_field(pass, "vcov", "", vcov)
     968      CALL put_field(pass, "temp", "", temp)
     969      CALL put_field(pass, "omega2", "", omega2)
     970
     971      Do iq = 1, nqtot
     972        CALL put_field(pass, "q" // nmq(iq), "eau vap ou condens et traceurs", &
     973                &                                                      q(:, :, iq))
     974      EndDo
     975      IF (pass==1) CALL enddef_restartphy
     976      IF (pass==2) CALL close_restartphy
     977
     978    ENDDO
     979
     980    RETURN
     981  END SUBROUTINE dyn1dredem
     982
     983
     984  SUBROUTINE gr_fi_dyn(nfield, ngrid, im, jm, pfi, pdyn)
     985    IMPLICIT NONE
     986    !=======================================================================
     987    !   passage d'un champ de la grille scalaire a la grille physique
     988    !=======================================================================
     989
     990    !-----------------------------------------------------------------------
     991    !   declarations:
     992    !   -------------
     993
     994    INTEGER im, jm, ngrid, nfield
     995    REAL pdyn(im, jm, nfield)
     996    REAL pfi(ngrid, nfield)
     997
     998    INTEGER i, j, ifield, ig
     999
     1000    !-----------------------------------------------------------------------
     1001    !   calcul:
     1002    !   -------
     1003
     1004    DO ifield = 1, nfield
     1005      !   traitement des poles
     1006      DO i = 1, im
     1007        pdyn(i, 1, ifield) = pfi(1, ifield)
     1008        pdyn(i, jm, ifield) = pfi(ngrid, ifield)
     1009      ENDDO
     1010
     1011      !   traitement des point normaux
     1012      DO j = 2, jm - 1
     1013        ig = 2 + (j - 2) * (im - 1)
     1014        CALL SCOPY(im - 1, pfi(ig, ifield), 1, pdyn(1, j, ifield), 1)
     1015        pdyn(im, j, ifield) = pdyn(1, j, ifield)
     1016      ENDDO
     1017    ENDDO
     1018
     1019    RETURN
     1020  END SUBROUTINE gr_fi_dyn
     1021
     1022
     1023  SUBROUTINE abort_gcm(modname, message, ierr)
     1024    USE IOIPSL
     1025
     1026    ! Stops the simulation cleanly, closing files and printing various
     1027    ! comments
     1028
     1029    !  Input: modname = name of calling program
     1030    !         message = stuff to print
     1031    !         ierr    = severity of situation ( = 0 normal )
     1032
     1033    character(len = *) modname
     1034    integer ierr
     1035    character(len = *) message
     1036
     1037    write(*, *) 'in abort_gcm'
     1038    CALL histclo
     1039    !     CALL histclo(2)
     1040    !     CALL histclo(3)
     1041    !     CALL histclo(4)
     1042    !     CALL histclo(5)
     1043    write(*, *) 'out of histclo'
     1044    write(*, *) 'Stopping in ', modname
     1045    write(*, *) 'Reason = ', message
     1046    CALL getin_dump
     1047
     1048    if (ierr == 0) then
     1049      write(*, *) 'Everything is cool'
     1050    else
     1051      write(*, *) 'Houston, we have a problem ', ierr
     1052    endif
     1053    STOP
     1054  END SUBROUTINE abort_gcm
     1055
     1056
     1057  SUBROUTINE gr_dyn_fi(nfield, im, jm, ngrid, pdyn, pfi)
     1058    IMPLICIT NONE
     1059    !=======================================================================
     1060    !   passage d'un champ de la grille scalaire a la grille physique
     1061    !=======================================================================
     1062
     1063    !-----------------------------------------------------------------------
     1064    !   declarations:
     1065    !   -------------
     1066
     1067    INTEGER im, jm, ngrid, nfield
     1068    REAL pdyn(im, jm, nfield)
     1069    REAL pfi(ngrid, nfield)
     1070
     1071    INTEGER j, ifield, ig
     1072
     1073    !-----------------------------------------------------------------------
     1074    !   calcul:
     1075    !   -------
     1076
     1077    IF(ngrid/=2 + (jm - 2) * (im - 1).AND.ngrid/=1)                          &
     1078            &    STOP 'probleme de dim'
    9641079    !   traitement des poles
    965     DO i = 1, im
    966       pdyn(i, 1, ifield) = pfi(1, ifield)
    967       pdyn(i, jm, ifield) = pfi(ngrid, ifield)
     1080    CALL SCOPY(nfield, pdyn, im * jm, pfi, ngrid)
     1081    CALL SCOPY(nfield, pdyn(1, jm, 1), im * jm, pfi(ngrid, 1), ngrid)
     1082
     1083    !   traitement des point normaux
     1084    DO ifield = 1, nfield
     1085      DO j = 2, jm - 1
     1086        ig = 2 + (j - 2) * (im - 1)
     1087        CALL SCOPY(im - 1, pdyn(1, j, ifield), 1, pfi(ig, ifield), 1)
     1088      ENDDO
    9681089    ENDDO
    969 
    970     !   traitement des point normaux
    971     DO j = 2, jm - 1
    972       ig = 2 + (j - 2) * (im - 1)
    973       CALL SCOPY(im - 1, pfi(ig, ifield), 1, pdyn(1, j, ifield), 1)
    974       pdyn(im, j, ifield) = pdyn(1, j, ifield)
     1090  END SUBROUTINE gr_dyn_fi
     1091
     1092
     1093  SUBROUTINE disvert0(pa, preff, ap, bp, dpres, presnivs, nivsigs, nivsig)
     1094
     1095    !    Ancienne version disvert dont on a modifie nom pour utiliser
     1096    !    le disvert de dyn3d (qui permet d'utiliser grille avec ab,bp imposes)
     1097    !    (MPL 18092012)
     1098
     1099    !    Auteur :  P. Le Van .
     1100
     1101    IMPLICIT NONE
     1102
     1103    include "dimensions.h"
     1104    include "paramet.h"
     1105
     1106    !=======================================================================
     1107
     1108
     1109    !    s = sigma ** kappa   :  coordonnee  verticale
     1110    !    dsig(l)            : epaisseur de la couche l ds la coord.  s
     1111    !    sig(l)             : sigma a l'interface des couches l et l-1
     1112    !    ds(l)              : distance entre les couches l et l-1 en coord.s
     1113
     1114    !=======================================================================
     1115
     1116    REAL pa, preff
     1117    REAL ap(llmp1), bp(llmp1), dpres(llm), nivsigs(llm), nivsig(llmp1)
     1118    REAL presnivs(llm)
     1119
     1120    !   declarations:
     1121    !   -------------
     1122
     1123    REAL sig(llm + 1), dsig(llm)
     1124
     1125    INTEGER l
     1126    REAL snorm
     1127    REAL alpha, beta, gama, delta, deltaz, h
     1128    INTEGER np, ierr
     1129    REAL pi, x
     1130
     1131    !-----------------------------------------------------------------------
     1132
     1133    pi = 2. * ASIN(1.)
     1134
     1135    OPEN(99, file = 'sigma.def', status = 'old', form = 'formatted', &
     1136            &   iostat = ierr)
     1137
     1138    !-----------------------------------------------------------------------
     1139    !   cas 1 on lit les options dans sigma.def:
     1140    !   ----------------------------------------
     1141
     1142    IF (ierr==0) THEN
     1143
     1144      PRINT*, 'WARNING!!! on lit les options dans sigma.def'
     1145      READ(99, *) deltaz
     1146      READ(99, *) h
     1147      READ(99, *) beta
     1148      READ(99, *) gama
     1149      READ(99, *) delta
     1150      READ(99, *) np
     1151      CLOSE(99)
     1152      alpha = deltaz / (llm * h)
     1153
     1154      DO l = 1, llm
     1155        dsig(l) = (alpha + (1. - alpha) * exp(-beta * (llm - l))) * &
     1156                &          ((tanh(gama * l) / tanh(gama * llm))**np + &
     1157                        &            (1. - l / FLOAT(llm)) * delta)
     1158      END DO
     1159
     1160      sig(1) = 1.
     1161      DO l = 1, llm - 1
     1162        sig(l + 1) = sig(l) * (1. - dsig(l)) / (1. + dsig(l))
     1163      END DO
     1164      sig(llm + 1) = 0.
     1165
     1166      DO l = 1, llm
     1167        dsig(l) = sig(l) - sig(l + 1)
     1168      END DO
     1169
     1170    ELSE
     1171      !-----------------------------------------------------------------------
     1172      !   cas 2 ancienne discretisation (LMD5...):
     1173      !   ----------------------------------------
     1174
     1175      PRINT*, 'WARNING!!! Ancienne discretisation verticale'
     1176
     1177      h = 7.
     1178      snorm = 0.
     1179      DO l = 1, llm
     1180        x = 2. * asin(1.) * (FLOAT(l) - 0.5) / float(llm + 1)
     1181        dsig(l) = 1.0 + 7.0 * SIN(x)**2
     1182        snorm = snorm + dsig(l)
     1183      ENDDO
     1184      snorm = 1. / snorm
     1185      DO l = 1, llm
     1186        dsig(l) = dsig(l) * snorm
     1187      ENDDO
     1188      sig(llm + 1) = 0.
     1189      DO l = llm, 1, -1
     1190        sig(l) = sig(l + 1) + dsig(l)
     1191      ENDDO
     1192
     1193    ENDIF
     1194
     1195    DO l = 1, llm
     1196      nivsigs(l) = FLOAT(l)
    9751197    ENDDO
    976   ENDDO
    977 
    978   RETURN
    979 END
    980 
    981 
    982 SUBROUTINE abort_gcm(modname, message, ierr)
    983 
    984   USE IOIPSL
    985 
    986   ! Stops the simulation cleanly, closing files and printing various
    987   ! comments
    988 
    989   !  Input: modname = name of calling program
    990   !         message = stuff to print
    991   !         ierr    = severity of situation ( = 0 normal )
    992 
    993   character(len = *) modname
    994   integer ierr
    995   character(len = *) message
    996 
    997   write(*, *) 'in abort_gcm'
    998   CALL histclo
    999   !     CALL histclo(2)
    1000   !     CALL histclo(3)
    1001   !     CALL histclo(4)
    1002   !     CALL histclo(5)
    1003   write(*, *) 'out of histclo'
    1004   write(*, *) 'Stopping in ', modname
    1005   write(*, *) 'Reason = ', message
    1006   CALL getin_dump
    1007 
    1008   if (ierr == 0) then
    1009     write(*, *) 'Everything is cool'
    1010   else
    1011     write(*, *) 'Houston, we have a problem ', ierr
    1012   endif
    1013   STOP
    1014 END
    1015 REAL FUNCTION fq_sat(kelvin, millibar)
    1016 
    1017   IMPLICIT none
    1018   !======================================================================
    1019   ! Autheur(s): Z.X. Li (LMD/CNRS)
    1020   ! Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
    1021   !======================================================================
    1022   ! Arguments:
    1023   ! kelvin---input-R: temperature en Kelvin
    1024   ! millibar--input-R: pression en mb
    1025 
    1026   ! fq_sat----output-R: vapeur d'eau saturante en kg/kg
    1027   !======================================================================
    1028 
    1029   REAL kelvin, millibar
    1030 
    1031   REAL r2es
    1032   PARAMETER (r2es = 611.14 * 18.0153 / 28.9644)
    1033 
    1034   REAL r3les, r3ies, r3es
    1035   PARAMETER (R3LES = 17.269)
    1036   PARAMETER (R3IES = 21.875)
    1037 
    1038   REAL r4les, r4ies, r4es
    1039   PARAMETER (R4LES = 35.86)
    1040   PARAMETER (R4IES = 7.66)
    1041 
    1042   REAL rtt
    1043   PARAMETER (rtt = 273.16)
    1044 
    1045   REAL retv
    1046   PARAMETER (retv = 28.9644 / 18.0153 - 1.0)
    1047 
    1048   REAL zqsat
    1049   REAL temp, pres
    1050   !     ------------------------------------------------------------------
    1051 
    1052   temp = kelvin
    1053   pres = millibar * 100.0
    1054   !      write(*,*)'kelvin,millibar=',kelvin,millibar
    1055   !      write(*,*)'temp,pres=',temp,pres
    1056 
    1057   IF (temp <= rtt) THEN
    1058     r3es = r3ies
    1059     r4es = r4ies
    1060   ELSE
    1061     r3es = r3les
    1062     r4es = r4les
    1063   ENDIF
    1064 
    1065   zqsat = r2es / pres * EXP (r3es * (temp - rtt) / (temp - r4es))
    1066   zqsat = MIN(0.5, ZQSAT)
    1067   zqsat = zqsat / (1. - retv * zqsat)
    1068 
    1069   fq_sat = zqsat
    1070 
    1071   RETURN
    1072 END
    1073 
    1074 SUBROUTINE gr_dyn_fi(nfield, im, jm, ngrid, pdyn, pfi)
    1075   IMPLICIT NONE
    1076   !=======================================================================
    1077   !   passage d'un champ de la grille scalaire a la grille physique
    1078   !=======================================================================
    1079 
    1080   !-----------------------------------------------------------------------
    1081   !   declarations:
    1082   !   -------------
    1083 
    1084   INTEGER im, jm, ngrid, nfield
    1085   REAL pdyn(im, jm, nfield)
    1086   REAL pfi(ngrid, nfield)
    1087 
    1088   INTEGER j, ifield, ig
    1089 
    1090   !-----------------------------------------------------------------------
    1091   !   calcul:
    1092   !   -------
    1093 
    1094   IF(ngrid/=2 + (jm - 2) * (im - 1).AND.ngrid/=1)                          &
    1095           &    STOP 'probleme de dim'
    1096   !   traitement des poles
    1097   CALL SCOPY(nfield, pdyn, im * jm, pfi, ngrid)
    1098   CALL SCOPY(nfield, pdyn(1, jm, 1), im * jm, pfi(ngrid, 1), ngrid)
    1099 
    1100   !   traitement des point normaux
    1101   DO ifield = 1, nfield
    1102     DO j = 2, jm - 1
    1103       ig = 2 + (j - 2) * (im - 1)
    1104       CALL SCOPY(im - 1, pdyn(1, j, ifield), 1, pfi(ig, ifield), 1)
     1198
     1199    DO l = 1, llmp1
     1200      nivsig(l) = FLOAT(l)
    11051201    ENDDO
    1106   ENDDO
    1107 
    1108   RETURN
    1109 END
    1110 
    1111 SUBROUTINE disvert0(pa, preff, ap, bp, dpres, presnivs, nivsigs, nivsig)
    1112 
    1113   !    Ancienne version disvert dont on a modifie nom pour utiliser
    1114   !    le disvert de dyn3d (qui permet d'utiliser grille avec ab,bp imposes)
    1115   !    (MPL 18092012)
    1116 
    1117   !    Auteur :  P. Le Van .
    1118 
    1119   IMPLICIT NONE
    1120 
    1121   include "dimensions.h"
    1122   include "paramet.h"
    1123 
    1124   !=======================================================================
    1125 
    1126 
    1127   !    s = sigma ** kappa   :  coordonnee  verticale
    1128   !    dsig(l)            : epaisseur de la couche l ds la coord.  s
    1129   !    sig(l)             : sigma a l'interface des couches l et l-1
    1130   !    ds(l)              : distance entre les couches l et l-1 en coord.s
    1131 
    1132   !=======================================================================
    1133 
    1134   REAL pa, preff
    1135   REAL ap(llmp1), bp(llmp1), dpres(llm), nivsigs(llm), nivsig(llmp1)
    1136   REAL presnivs(llm)
    1137 
    1138   !   declarations:
    1139   !   -------------
    1140 
    1141   REAL sig(llm + 1), dsig(llm)
    1142 
    1143   INTEGER l
    1144   REAL snorm
    1145   REAL alpha, beta, gama, delta, deltaz, h
    1146   INTEGER np, ierr
    1147   REAL pi, x
    1148 
    1149   !-----------------------------------------------------------------------
    1150 
    1151   pi = 2. * ASIN(1.)
    1152 
    1153   OPEN(99, file = 'sigma.def', status = 'old', form = 'formatted', &
    1154           &   iostat = ierr)
    1155 
    1156   !-----------------------------------------------------------------------
    1157   !   cas 1 on lit les options dans sigma.def:
    1158   !   ----------------------------------------
    1159 
    1160   IF (ierr==0) THEN
    1161 
    1162     PRINT*, 'WARNING!!! on lit les options dans sigma.def'
    1163     READ(99, *) deltaz
    1164     READ(99, *) h
    1165     READ(99, *) beta
    1166     READ(99, *) gama
    1167     READ(99, *) delta
    1168     READ(99, *) np
    1169     CLOSE(99)
    1170     alpha = deltaz / (llm * h)
     1202
     1203    !    ....  Calculs  de ap(l) et de bp(l)  ....
     1204    !    .........................................
     1205
     1206    !   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
     1207
     1208    bp(llmp1) = 0.
    11711209
    11721210    DO l = 1, llm
    1173       dsig(l) = (alpha + (1. - alpha) * exp(-beta * (llm - l))) * &
    1174               &          ((tanh(gama * l) / tanh(gama * llm))**np + &
    1175                       &            (1. - l / FLOAT(llm)) * delta)
    1176     END DO
    1177 
    1178     sig(1) = 1.
    1179     DO l = 1, llm - 1
    1180       sig(l + 1) = sig(l) * (1. - dsig(l)) / (1. + dsig(l))
    1181     END DO
    1182     sig(llm + 1) = 0.
     1211      !c
     1212      !cc    ap(l) = 0.
     1213      !cc    bp(l) = sig(l)
     1214
     1215      bp(l) = EXP(1. - 1. / (sig(l) * sig(l)))
     1216      ap(l) = pa * (sig(l) - bp(l))
     1217
     1218    ENDDO
     1219    ap(llmp1) = pa * (sig(llmp1) - bp(llmp1))
     1220
     1221    PRINT *, ' BP '
     1222    PRINT *, bp
     1223    PRINT *, ' AP '
     1224    PRINT *, ap
    11831225
    11841226    DO l = 1, llm
    1185       dsig(l) = sig(l) - sig(l + 1)
    1186     END DO
    1187 
    1188   ELSE
    1189     !-----------------------------------------------------------------------
    1190     !   cas 2 ancienne discretisation (LMD5...):
    1191     !   ----------------------------------------
    1192 
    1193     PRINT*, 'WARNING!!! Ancienne discretisation verticale'
    1194 
    1195     h = 7.
    1196     snorm = 0.
    1197     DO l = 1, llm
    1198       x = 2. * asin(1.) * (FLOAT(l) - 0.5) / float(llm + 1)
    1199       dsig(l) = 1.0 + 7.0 * SIN(x)**2
    1200       snorm = snorm + dsig(l)
     1227      dpres(l) = bp(l) - bp(l + 1)
     1228      presnivs(l) = 0.5 * (ap(l) + bp(l) * preff + ap(l + 1) + bp(l + 1) * preff)
    12011229    ENDDO
    1202     snorm = 1. / snorm
    1203     DO l = 1, llm
    1204       dsig(l) = dsig(l) * snorm
    1205     ENDDO
    1206     sig(llm + 1) = 0.
    1207     DO l = llm, 1, -1
    1208       sig(l) = sig(l + 1) + dsig(l)
    1209     ENDDO
    1210 
    1211   ENDIF
    1212 
    1213   DO l = 1, llm
    1214     nivsigs(l) = FLOAT(l)
    1215   ENDDO
    1216 
    1217   DO l = 1, llmp1
    1218     nivsig(l) = FLOAT(l)
    1219   ENDDO
    1220 
    1221   !    ....  Calculs  de ap(l) et de bp(l)  ....
    1222   !    .........................................
    1223 
    1224   !   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
    1225 
    1226   bp(llmp1) = 0.
    1227 
    1228   DO l = 1, llm
    1229     !c
    1230     !cc    ap(l) = 0.
    1231     !cc    bp(l) = sig(l)
    1232 
    1233     bp(l) = EXP(1. - 1. / (sig(l) * sig(l)))
    1234     ap(l) = pa * (sig(l) - bp(l))
    1235 
    1236   ENDDO
    1237   ap(llmp1) = pa * (sig(llmp1) - bp(llmp1))
    1238 
    1239   PRINT *, ' BP '
    1240   PRINT *, bp
    1241   PRINT *, ' AP '
    1242   PRINT *, ap
    1243 
    1244   DO l = 1, llm
    1245     dpres(l) = bp(l) - bp(l + 1)
    1246     presnivs(l) = 0.5 * (ap(l) + bp(l) * preff + ap(l + 1) + bp(l + 1) * preff)
    1247   ENDDO
    1248 
    1249   PRINT *, ' PRESNIVS '
    1250   PRINT *, presnivs
    1251 
    1252   RETURN
    1253 END
    1254 
    1255 !!======================================================================
    1256 !       SUBROUTINE read_tsurf1d(knon,sst_out)
    1257 
    1258 !! This subroutine specifies the surface temperature to be used in 1D simulations
    1259 
    1260 !      USE dimphy, ONLY: klon
    1261 
    1262 !      INTEGER, INTENT(IN)                  :: knon     ! nomber of points on compressed grid
    1263 !      REAL, DIMENSION(klon), INTENT(OUT)   :: sst_out  ! tsurf used to force the single-column model
    1264 
    1265 !       INTEGER :: i
    1266 !! COMMON defined in lmdz1d.F:
    1267 !       real ts_cur
    1268 !       common /sst_forcing/ts_cur
    1269 
    1270 !       DO i = 1, knon
    1271 !        sst_out(i) = ts_cur
    1272 !       ENDDO
    1273 
    1274 !      END SUBROUTINE read_tsurf1d
    1275 
    1276 !===============================================================
    1277 subroutine advect_vert(llm, w, dt, q, plev)
    1278   !===============================================================
    1279   !   Schema amont pour l'advection verticale en 1D
    1280   !   w est la vitesse verticale dp/dt en Pa/s
    1281   !   Traitement en volumes finis
    1282   !   d / dt ( zm q ) = delta_z ( omega q )
    1283   !   d / dt ( zm ) = delta_z ( omega )
    1284   !   avec zm = delta_z ( p )
    1285   !   si * designe la valeur au pas de temps t+dt
    1286   !   zm*(l) q*(l) - zm(l) q(l) = w(l+1) q(l+1) - w(l) q(l)
    1287   !   zm*(l) -zm(l) = w(l+1) - w(l)
    1288   !   avec w=omega * dt
    1289   !---------------------------------------------------------------
    1290   implicit none
    1291   ! arguments
    1292   integer llm
    1293   real w(llm + 1), q(llm), plev(llm + 1), dt
    1294 
    1295   ! local
    1296   integer l
    1297   real zwq(llm + 1), zm(llm + 1), zw(llm + 1)
    1298   real qold
    1299 
    1300   !---------------------------------------------------------------
    1301 
    1302   do l = 1, llm
    1303     zw(l) = dt * w(l)
    1304     zm(l) = plev(l) - plev(l + 1)
    1305     zwq(l) = q(l) * zw(l)
    1306   enddo
    1307   zwq(llm + 1) = 0.
    1308   zw(llm + 1) = 0.
    1309 
    1310   do l = 1, llm
    1311     qold = q(l)
    1312     q(l) = (q(l) * zm(l) + zwq(l + 1) - zwq(l)) / (zm(l) + zw(l + 1) - zw(l))
    1313     PRINT*, 'ADV Q ', zm(l), zw(l), zwq(l), qold, q(l)
    1314   enddo
    1315 
    1316   return
    1317 end
    1318 
    1319 !===============================================================
    1320 
    1321 
    1322 SUBROUTINE advect_va(llm, omega, d_t_va, d_q_va, d_u_va, d_v_va, &
    1323         &                q, temp, u, v, play)
    1324   !itlmd
    1325   !----------------------------------------------------------------------
    1326   !   Calcul de l'advection verticale (ascendance et subsidence) de
    1327   !   temperature et d'humidite. Hypothese : ce qui rentre de l'exterieur
    1328   !   a les memes caracteristiques que l'air de la colonne 1D (WTG) ou
    1329   !   sans WTG rajouter une advection horizontale
    1330   !----------------------------------------------------------------------
    1331   implicit none
    1332   include "YOMCST.h"
    1333   !        argument
    1334   integer llm
    1335   real  omega(llm + 1), d_t_va(llm), d_q_va(llm, 3)
    1336   real  d_u_va(llm), d_v_va(llm)
    1337   real  q(llm, 3), temp(llm)
    1338   real  u(llm), v(llm)
    1339   real  play(llm)
    1340   ! interne
    1341   integer l
    1342   real alpha, omgdown, omgup
    1343 
    1344   do l = 1, llm
    1345     if(l==1) then
    1346       !si omgup pour la couche 1, alors tendance nulle
    1347       omgdown = max(omega(2), 0.0)
    1348       alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
    1349       d_t_va(l) = alpha * (omgdown) - omgdown * (temp(l) - temp(l + 1))             &
    1350               & / (play(l) - play(l + 1))
    1351 
    1352       d_q_va(l, :) = -omgdown * (q(l, :) - q(l + 1, :)) / (play(l) - play(l + 1))
    1353 
    1354       d_u_va(l) = -omgdown * (u(l) - u(l + 1)) / (play(l) - play(l + 1))
    1355       d_v_va(l) = -omgdown * (v(l) - v(l + 1)) / (play(l) - play(l + 1))
    1356 
    1357     elseif(l==llm) then
    1358       omgup = min(omega(l), 0.0)
    1359       alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
    1360       d_t_va(l) = alpha * (omgup) - &
    1361 
    1362               !bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
    1363               &              omgup * (temp(l - 1) - temp(l)) / (play(l - 1) - play(l))
    1364       d_q_va(l, :) = -omgup * (q(l - 1, :) - q(l, :)) / (play(l - 1) - play(l))
    1365       d_u_va(l) = -omgup * (u(l - 1) - u(l)) / (play(l - 1) - play(l))
    1366       d_v_va(l) = -omgup * (v(l - 1) - v(l)) / (play(l - 1) - play(l))
    1367 
    1368     else
    1369       omgup = min(omega(l), 0.0)
    1370       omgdown = max(omega(l + 1), 0.0)
    1371       alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
    1372       d_t_va(l) = alpha * (omgup + omgdown) - omgdown * (temp(l) - temp(l + 1))       &
    1373               & / (play(l) - play(l + 1)) - &
    1374               !bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
    1375               &              omgup * (temp(l - 1) - temp(l)) / (play(l - 1) - play(l))
    1376       !      PRINT*, '  ??? '
    1377 
    1378       d_q_va(l, :) = -omgdown * (q(l, :) - q(l + 1, :))                            &
    1379               & / (play(l) - play(l + 1)) - &
    1380               &              omgup * (q(l - 1, :) - q(l, :)) / (play(l - 1) - play(l))
    1381       d_u_va(l) = -omgdown * (u(l) - u(l + 1))                                  &
    1382               & / (play(l) - play(l + 1)) - &
    1383               &              omgup * (u(l - 1) - u(l)) / (play(l - 1) - play(l))
    1384       d_v_va(l) = -omgdown * (v(l) - v(l + 1))                                  &
    1385               & / (play(l) - play(l + 1)) - &
    1386               &              omgup * (v(l - 1) - v(l)) / (play(l - 1) - play(l))
    1387 
    1388     endif
    1389 
    1390   enddo
    1391   !fin itlmd
    1392   return
    1393 end
    1394 !       SUBROUTINE lstendH(llm,omega,d_t_va,d_q_va,d_u_va,d_v_va,
    1395 SUBROUTINE lstendH(llm, nqtot, omega, d_t_va, d_q_va, &
    1396         &                q, temp, u, v, play)
    1397   !itlmd
    1398   !----------------------------------------------------------------------
    1399   !   Calcul de l'advection verticale (ascendance et subsidence) de
    1400   !   temperature et d'humidite. Hypothese : ce qui rentre de l'exterieur
    1401   !   a les memes caracteristiques que l'air de la colonne 1D (WTG) ou
    1402   !   sans WTG rajouter une advection horizontale
    1403   !----------------------------------------------------------------------
    1404   implicit none
    1405   include "YOMCST.h"
    1406   !        argument
    1407   integer llm, nqtot
    1408   real  omega(llm + 1), d_t_va(llm), d_q_va(llm, nqtot)
    1409   !        real  d_u_va(llm), d_v_va(llm)
    1410   real  q(llm, nqtot), temp(llm)
    1411   real  u(llm), v(llm)
    1412   real  play(llm)
    1413   real cor(llm)
    1414   !        real dph(llm),dudp(llm),dvdp(llm),dqdp(llm),dtdp(llm)
    1415   real dph(llm), dqdp(llm), dtdp(llm)
    1416   ! interne
    1417   integer k
    1418   real omdn, omup
    1419 
    1420   !        dudp=0.
    1421   !        dvdp=0.
    1422   dqdp = 0.
    1423   dtdp = 0.
    1424   !        d_u_va=0.
    1425   !        d_v_va=0.
    1426 
    1427   cor(:) = rkappa * temp * (1. + q(:, 1) * rv / rd) / (play * (1. + q(:, 1)))
    1428 
    1429   do k = 2, llm - 1
    1430 
    1431     dph  (k - 1) = (play(k) - play(k - 1))
    1432     !       dudp (k-1) = (u   (k  )- u   (k-1  ))/dph(k-1)
    1433     !       dvdp (k-1) = (v   (k  )- v   (k-1  ))/dph(k-1)
    1434     dqdp (k - 1) = (q   (k, 1) - q   (k - 1, 1)) / dph(k - 1)
    1435     dtdp (k - 1) = (temp(k) - temp(k - 1)) / dph(k - 1)
    1436 
    1437   enddo
    1438 
    1439   !      dudp (  llm  ) = dudp ( llm-1 )
    1440   !      dvdp (  llm  ) = dvdp ( llm-1 )
    1441   dqdp (llm) = dqdp (llm - 1)
    1442   dtdp (llm) = dtdp (llm - 1)
    1443 
    1444   do k = 2, llm - 1
    1445     omdn = max(0.0, omega(k + 1))
    1446     omup = min(0.0, omega(k))
    1447 
    1448     !      d_u_va(k)  = -omdn*dudp(k)-omup*dudp(k-1)
    1449     !      d_v_va(k)  = -omdn*dvdp(k)-omup*dvdp(k-1)
    1450     d_q_va(k, 1) = -omdn * dqdp(k) - omup * dqdp(k - 1)
    1451     d_t_va(k) = -omdn * dtdp(k) - omup * dtdp(k - 1) + (omup + omdn) * cor(k)
    1452   enddo
    1453 
    1454   omdn = max(0.0, omega(2))
    1455   omup = min(0.0, omega(llm))
    1456   !      d_u_va( 1 )   = -omdn*dudp( 1 )
    1457   !      d_u_va(llm)   = -omup*dudp(llm)
    1458   !      d_v_va( 1 )   = -omdn*dvdp( 1 )
    1459   !      d_v_va(llm)   = -omup*dvdp(llm)
    1460   d_q_va(1, 1) = -omdn * dqdp(1)
    1461   d_q_va(llm, 1) = -omup * dqdp(llm)
    1462   d_t_va(1) = -omdn * dtdp(1) + omdn * cor(1)
    1463   d_t_va(llm) = -omup * dtdp(llm)!+omup*cor(llm)
    1464 
    1465   !      if(abs(rlat(1))>10.) then
    1466   !     Calculate the tendency due agestrophic motions
    1467   !      du_age = fcoriolis*(v-vg)
    1468   !      dv_age = fcoriolis*(ug-u)
    1469   !      endif
    1470 
    1471   !       CALL writefield_phy('d_t_va',d_t_va,llm)
    1472 
    1473   return
    1474 end
    1475 
    1476 !======================================================================
    1477 
    1478 !  Subroutines for nudging
    1479 
    1480 Subroutine Nudge_RHT_init (paprs, pplay, t, q, t_targ, rh_targ)
    1481   ! ========================================================
    1482   USE dimphy
    1483 
    1484   implicit none
    1485 
    1486   ! ========================================================
    1487   REAL paprs(klon, klevp1)
    1488   REAL pplay(klon, klev)
    1489 
    1490   !      Variables d'etat
    1491   REAL t(klon, klev)
    1492   REAL q(klon, klev)
    1493 
    1494   !   Profiles cible
    1495   REAL t_targ(klon, klev)
    1496   REAL rh_targ(klon, klev)
    1497 
    1498   INTEGER k, i
    1499   REAL zx_qs
    1500 
    1501   ! Declaration des constantes et des fonctions thermodynamiques
    1502 
    1503   include "YOMCST.h"
    1504   include "YOETHF.h"
    1505 
    1506   !  ----------------------------------------
    1507   !  Statement functions
    1508   include "FCTTRE.h"
    1509   !  ----------------------------------------
    1510 
    1511   DO k = 1, klev
    1512     DO i = 1, klon
    1513       t_targ(i, k) = t(i, k)
    1514       IF (t(i, k)<RTT) THEN
    1515         zx_qs = qsats(t(i, k)) / (pplay(i, k))
    1516       ELSE
    1517         zx_qs = qsatl(t(i, k)) / (pplay(i, k))
    1518       ENDIF
    1519       rh_targ(i, k) = q(i, k) / zx_qs
    1520     ENDDO
    1521   ENDDO
    1522   print *, 't_targ', t_targ
    1523   print *, 'rh_targ', rh_targ
    1524 
    1525   RETURN
    1526 END
    1527 
    1528 Subroutine Nudge_UV_init (paprs, pplay, u, v, u_targ, v_targ)
    1529   ! ========================================================
    1530   USE dimphy
    1531 
    1532   implicit none
    1533 
    1534   ! ========================================================
    1535   REAL paprs(klon, klevp1)
    1536   REAL pplay(klon, klev)
    1537 
    1538   !      Variables d'etat
    1539   REAL u(klon, klev)
    1540   REAL v(klon, klev)
    1541 
    1542   !   Profiles cible
    1543   REAL u_targ(klon, klev)
    1544   REAL v_targ(klon, klev)
    1545 
    1546   INTEGER k, i
    1547 
    1548   DO k = 1, klev
    1549     DO i = 1, klon
    1550       u_targ(i, k) = u(i, k)
    1551       v_targ(i, k) = v(i, k)
    1552     ENDDO
    1553   ENDDO
    1554   print *, 'u_targ', u_targ
    1555   print *, 'v_targ', v_targ
    1556 
    1557   RETURN
    1558 END
    1559 
    1560 Subroutine Nudge_RHT (dtime, paprs, pplay, t_targ, rh_targ, t, q, &
    1561         &                      d_t, d_q)
    1562   ! ========================================================
    1563   USE dimphy
    1564 
    1565   implicit none
    1566 
    1567   ! ========================================================
    1568   REAL dtime
    1569   REAL paprs(klon, klevp1)
    1570   REAL pplay(klon, klev)
    1571 
    1572   !      Variables d'etat
    1573   REAL t(klon, klev)
    1574   REAL q(klon, klev)
    1575 
    1576   ! Tendances
    1577   REAL d_t(klon, klev)
    1578   REAL d_q(klon, klev)
    1579 
    1580   !   Profiles cible
    1581   REAL t_targ(klon, klev)
    1582   REAL rh_targ(klon, klev)
    1583 
    1584   !   Temps de relaxation
    1585   REAL tau
    1586   !c      DATA tau /3600./
    1587   !!      DATA tau /5400./
    1588   DATA tau /1800./
    1589 
    1590   INTEGER k, i
    1591   REAL zx_qs, rh, tnew, d_rh, rhnew
    1592 
    1593   ! Declaration des constantes et des fonctions thermodynamiques
    1594 
    1595   include "YOMCST.h"
    1596   include "YOETHF.h"
    1597 
    1598   !  ----------------------------------------
    1599   !  Statement functions
    1600   include "FCTTRE.h"
    1601   !  ----------------------------------------
    1602 
    1603   print *, 'dtime, tau ', dtime, tau
    1604   print *, 't_targ', t_targ
    1605   print *, 'rh_targ', rh_targ
    1606   print *, 'temp ', t
    1607   print *, 'hum ', q
    1608 
    1609   DO k = 1, klev
    1610     DO i = 1, klon
    1611       IF (paprs(i, 1) - pplay(i, k) > 10000.) THEN
     1230
     1231    PRINT *, ' PRESNIVS '
     1232    PRINT *, presnivs
     1233  END SUBROUTINE disvert0
     1234
     1235  subroutine advect_vert(llm, w, dt, q, plev)
     1236    !===============================================================
     1237    !   Schema amont pour l'advection verticale en 1D
     1238    !   w est la vitesse verticale dp/dt en Pa/s
     1239    !   Traitement en volumes finis
     1240    !   d / dt ( zm q ) = delta_z ( omega q )
     1241    !   d / dt ( zm ) = delta_z ( omega )
     1242    !   avec zm = delta_z ( p )
     1243    !   si * designe la valeur au pas de temps t+dt
     1244    !   zm*(l) q*(l) - zm(l) q(l) = w(l+1) q(l+1) - w(l) q(l)
     1245    !   zm*(l) -zm(l) = w(l+1) - w(l)
     1246    !   avec w=omega * dt
     1247    !---------------------------------------------------------------
     1248    implicit none
     1249    ! arguments
     1250    integer llm
     1251    real w(llm + 1), q(llm), plev(llm + 1), dt
     1252
     1253    ! local
     1254    integer l
     1255    real zwq(llm + 1), zm(llm + 1), zw(llm + 1)
     1256    real qold
     1257
     1258    !---------------------------------------------------------------
     1259
     1260    do l = 1, llm
     1261      zw(l) = dt * w(l)
     1262      zm(l) = plev(l) - plev(l + 1)
     1263      zwq(l) = q(l) * zw(l)
     1264    enddo
     1265    zwq(llm + 1) = 0.
     1266    zw(llm + 1) = 0.
     1267
     1268    do l = 1, llm
     1269      qold = q(l)
     1270      q(l) = (q(l) * zm(l) + zwq(l + 1) - zwq(l)) / (zm(l) + zw(l + 1) - zw(l))
     1271      PRINT*, 'ADV Q ', zm(l), zw(l), zwq(l), qold, q(l)
     1272    enddo
     1273  end SUBROUTINE advect_vert
     1274
     1275  SUBROUTINE advect_va(llm, omega, d_t_va, d_q_va, d_u_va, d_v_va, &
     1276          &                q, temp, u, v, play)
     1277    !itlmd
     1278    !----------------------------------------------------------------------
     1279    !   Calcul de l'advection verticale (ascendance et subsidence) de
     1280    !   temperature et d'humidite. Hypothese : ce qui rentre de l'exterieur
     1281    !   a les memes caracteristiques que l'air de la colonne 1D (WTG) ou
     1282    !   sans WTG rajouter une advection horizontale
     1283    !----------------------------------------------------------------------
     1284    implicit none
     1285    include "YOMCST.h"
     1286    !        argument
     1287    integer llm
     1288    real  omega(llm + 1), d_t_va(llm), d_q_va(llm, 3)
     1289    real  d_u_va(llm), d_v_va(llm)
     1290    real  q(llm, 3), temp(llm)
     1291    real  u(llm), v(llm)
     1292    real  play(llm)
     1293    ! interne
     1294    integer l
     1295    real alpha, omgdown, omgup
     1296
     1297    do l = 1, llm
     1298      if(l==1) then
     1299        !si omgup pour la couche 1, alors tendance nulle
     1300        omgdown = max(omega(2), 0.0)
     1301        alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
     1302        d_t_va(l) = alpha * (omgdown) - omgdown * (temp(l) - temp(l + 1))             &
     1303                & / (play(l) - play(l + 1))
     1304
     1305        d_q_va(l, :) = -omgdown * (q(l, :) - q(l + 1, :)) / (play(l) - play(l + 1))
     1306
     1307        d_u_va(l) = -omgdown * (u(l) - u(l + 1)) / (play(l) - play(l + 1))
     1308        d_v_va(l) = -omgdown * (v(l) - v(l + 1)) / (play(l) - play(l + 1))
     1309
     1310      elseif(l==llm) then
     1311        omgup = min(omega(l), 0.0)
     1312        alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
     1313        d_t_va(l) = alpha * (omgup) - &
     1314
     1315                !bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
     1316                &              omgup * (temp(l - 1) - temp(l)) / (play(l - 1) - play(l))
     1317        d_q_va(l, :) = -omgup * (q(l - 1, :) - q(l, :)) / (play(l - 1) - play(l))
     1318        d_u_va(l) = -omgup * (u(l - 1) - u(l)) / (play(l - 1) - play(l))
     1319        d_v_va(l) = -omgup * (v(l - 1) - v(l)) / (play(l - 1) - play(l))
     1320
     1321      else
     1322        omgup = min(omega(l), 0.0)
     1323        omgdown = max(omega(l + 1), 0.0)
     1324        alpha = rkappa * temp(l) * (1. + q(l, 1) * rv / rd) / (play(l) * (1. + q(l, 1)))
     1325        d_t_va(l) = alpha * (omgup + omgdown) - omgdown * (temp(l) - temp(l + 1))       &
     1326                & / (play(l) - play(l + 1)) - &
     1327                !bug?     &              omgup*(temp(l-1)-temp(l))/(play(l-1)-plev(l))
     1328                &              omgup * (temp(l - 1) - temp(l)) / (play(l - 1) - play(l))
     1329        !      PRINT*, '  ??? '
     1330
     1331        d_q_va(l, :) = -omgdown * (q(l, :) - q(l + 1, :))                            &
     1332                & / (play(l) - play(l + 1)) - &
     1333                &              omgup * (q(l - 1, :) - q(l, :)) / (play(l - 1) - play(l))
     1334        d_u_va(l) = -omgdown * (u(l) - u(l + 1))                                  &
     1335                & / (play(l) - play(l + 1)) - &
     1336                &              omgup * (u(l - 1) - u(l)) / (play(l - 1) - play(l))
     1337        d_v_va(l) = -omgdown * (v(l) - v(l + 1))                                  &
     1338                & / (play(l) - play(l + 1)) - &
     1339                &              omgup * (v(l - 1) - v(l)) / (play(l - 1) - play(l))
     1340
     1341      endif
     1342
     1343    enddo
     1344    !fin itlmd
     1345  end SUBROUTINE advect_va
     1346
     1347
     1348  SUBROUTINE lstendH(llm, nqtot, omega, d_t_va, d_q_va, q, temp, u, v, play)
     1349    !itlmd
     1350    !----------------------------------------------------------------------
     1351    !   Calcul de l'advection verticale (ascendance et subsidence) de
     1352    !   temperature et d'humidite. Hypothese : ce qui rentre de l'exterieur
     1353    !   a les memes caracteristiques que l'air de la colonne 1D (WTG) ou
     1354    !   sans WTG rajouter une advection horizontale
     1355    !----------------------------------------------------------------------
     1356    implicit none
     1357    include "YOMCST.h"
     1358    !        argument
     1359    integer llm, nqtot
     1360    real  omega(llm + 1), d_t_va(llm), d_q_va(llm, nqtot)
     1361    !        real  d_u_va(llm), d_v_va(llm)
     1362    real  q(llm, nqtot), temp(llm)
     1363    real  u(llm), v(llm)
     1364    real  play(llm)
     1365    real cor(llm)
     1366    !        real dph(llm),dudp(llm),dvdp(llm),dqdp(llm),dtdp(llm)
     1367    real dph(llm), dqdp(llm), dtdp(llm)
     1368    ! interne
     1369    integer k
     1370    real omdn, omup
     1371
     1372    !        dudp=0.
     1373    !        dvdp=0.
     1374    dqdp = 0.
     1375    dtdp = 0.
     1376    !        d_u_va=0.
     1377    !        d_v_va=0.
     1378
     1379    cor(:) = rkappa * temp * (1. + q(:, 1) * rv / rd) / (play * (1. + q(:, 1)))
     1380
     1381    do k = 2, llm - 1
     1382
     1383      dph  (k - 1) = (play(k) - play(k - 1))
     1384      !       dudp (k-1) = (u   (k  )- u   (k-1  ))/dph(k-1)
     1385      !       dvdp (k-1) = (v   (k  )- v   (k-1  ))/dph(k-1)
     1386      dqdp (k - 1) = (q   (k, 1) - q   (k - 1, 1)) / dph(k - 1)
     1387      dtdp (k - 1) = (temp(k) - temp(k - 1)) / dph(k - 1)
     1388
     1389    enddo
     1390
     1391    !      dudp (  llm  ) = dudp ( llm-1 )
     1392    !      dvdp (  llm  ) = dvdp ( llm-1 )
     1393    dqdp (llm) = dqdp (llm - 1)
     1394    dtdp (llm) = dtdp (llm - 1)
     1395
     1396    do k = 2, llm - 1
     1397      omdn = max(0.0, omega(k + 1))
     1398      omup = min(0.0, omega(k))
     1399
     1400      !      d_u_va(k)  = -omdn*dudp(k)-omup*dudp(k-1)
     1401      !      d_v_va(k)  = -omdn*dvdp(k)-omup*dvdp(k-1)
     1402      d_q_va(k, 1) = -omdn * dqdp(k) - omup * dqdp(k - 1)
     1403      d_t_va(k) = -omdn * dtdp(k) - omup * dtdp(k - 1) + (omup + omdn) * cor(k)
     1404    enddo
     1405
     1406    omdn = max(0.0, omega(2))
     1407    omup = min(0.0, omega(llm))
     1408    !      d_u_va( 1 )   = -omdn*dudp( 1 )
     1409    !      d_u_va(llm)   = -omup*dudp(llm)
     1410    !      d_v_va( 1 )   = -omdn*dvdp( 1 )
     1411    !      d_v_va(llm)   = -omup*dvdp(llm)
     1412    d_q_va(1, 1) = -omdn * dqdp(1)
     1413    d_q_va(llm, 1) = -omup * dqdp(llm)
     1414    d_t_va(1) = -omdn * dtdp(1) + omdn * cor(1)
     1415    d_t_va(llm) = -omup * dtdp(llm)!+omup*cor(llm)
     1416
     1417    !      if(abs(rlat(1))>10.) then
     1418    !     Calculate the tendency due agestrophic motions
     1419    !      du_age = fcoriolis*(v-vg)
     1420    !      dv_age = fcoriolis*(ug-u)
     1421    !      endif
     1422
     1423    !       CALL writefield_phy('d_t_va',d_t_va,llm)
     1424  end SUBROUTINE lstendH
     1425
     1426
     1427  Subroutine Nudge_RHT_init (paprs, pplay, t, q, t_targ, rh_targ)
     1428    ! ========================================================
     1429    USE dimphy
     1430
     1431    implicit none
     1432
     1433    ! ========================================================
     1434    REAL paprs(klon, klevp1)
     1435    REAL pplay(klon, klev)
     1436
     1437    !      Variables d'etat
     1438    REAL t(klon, klev)
     1439    REAL q(klon, klev)
     1440
     1441    !   Profiles cible
     1442    REAL t_targ(klon, klev)
     1443    REAL rh_targ(klon, klev)
     1444
     1445    INTEGER k, i
     1446    REAL zx_qs
     1447
     1448    ! Declaration des constantes et des fonctions thermodynamiques
     1449
     1450    include "YOMCST.h"
     1451    include "YOETHF.h"
     1452
     1453    !  ----------------------------------------
     1454    !  Statement functions
     1455    include "FCTTRE.h"
     1456    !  ----------------------------------------
     1457
     1458    DO k = 1, klev
     1459      DO i = 1, klon
     1460        t_targ(i, k) = t(i, k)
    16121461        IF (t(i, k)<RTT) THEN
    16131462          zx_qs = qsats(t(i, k)) / (pplay(i, k))
    … …  
    16151464          zx_qs = qsatl(t(i, k)) / (pplay(i, k))
    16161465        ENDIF
    1617         rh = q(i, k) / zx_qs
    1618 
    1619         d_t(i, k) = d_t(i, k) + 1. / tau * (t_targ(i, k) - t(i, k))
    1620         d_rh = 1. / tau * (rh_targ(i, k) - rh)
    1621 
    1622         tnew = t(i, k) + d_t(i, k) * dtime
    1623         !jyg<
    1624         !   Formule pour q :
    1625         !                         d_q = (1/tau) [rh_targ*qsat(T_new) - q]
    1626 
    1627         !  Cette formule remplace d_q = (1/tau) [rh_targ - rh] qsat(T_new)
    1628         !   qui n'etait pas correcte.
    1629 
    1630         IF (tnew<RTT) THEN
    1631           zx_qs = qsats(tnew) / (pplay(i, k))
    1632         ELSE
    1633           zx_qs = qsatl(tnew) / (pplay(i, k))
     1466        rh_targ(i, k) = q(i, k) / zx_qs
     1467      ENDDO
     1468    ENDDO
     1469    print *, 't_targ', t_targ
     1470    print *, 'rh_targ', rh_targ
     1471
     1472    RETURN
     1473  END SUBROUTINE nudge_rht_init
     1474
     1475  Subroutine Nudge_UV_init (paprs, pplay, u, v, u_targ, v_targ)
     1476    ! ========================================================
     1477    USE dimphy
     1478
     1479    implicit none
     1480
     1481    ! ========================================================
     1482    REAL paprs(klon, klevp1)
     1483    REAL pplay(klon, klev)
     1484
     1485    !      Variables d'etat
     1486    REAL u(klon, klev)
     1487    REAL v(klon, klev)
     1488
     1489    !   Profiles cible
     1490    REAL u_targ(klon, klev)
     1491    REAL v_targ(klon, klev)
     1492
     1493    INTEGER k, i
     1494
     1495    DO k = 1, klev
     1496      DO i = 1, klon
     1497        u_targ(i, k) = u(i, k)
     1498        v_targ(i, k) = v(i, k)
     1499      ENDDO
     1500    ENDDO
     1501    print *, 'u_targ', u_targ
     1502    print *, 'v_targ', v_targ
     1503
     1504    RETURN
     1505  END
     1506
     1507  Subroutine Nudge_RHT (dtime, paprs, pplay, t_targ, rh_targ, t, q, &
     1508          &                      d_t, d_q)
     1509    ! ========================================================
     1510    USE dimphy
     1511
     1512    implicit none
     1513
     1514    ! ========================================================
     1515    REAL dtime
     1516    REAL paprs(klon, klevp1)
     1517    REAL pplay(klon, klev)
     1518
     1519    !      Variables d'etat
     1520    REAL t(klon, klev)
     1521    REAL q(klon, klev)
     1522
     1523    ! Tendances
     1524    REAL d_t(klon, klev)
     1525    REAL d_q(klon, klev)
     1526
     1527    !   Profiles cible
     1528    REAL t_targ(klon, klev)
     1529    REAL rh_targ(klon, klev)
     1530
     1531    !   Temps de relaxation
     1532    REAL tau
     1533    !c      DATA tau /3600./
     1534    !!      DATA tau /5400./
     1535    DATA tau /1800./
     1536
     1537    INTEGER k, i
     1538    REAL zx_qs, rh, tnew, d_rh, rhnew
     1539
     1540    ! Declaration des constantes et des fonctions thermodynamiques
     1541
     1542    include "YOMCST.h"
     1543    include "YOETHF.h"
     1544
     1545    !  ----------------------------------------
     1546    !  Statement functions
     1547    include "FCTTRE.h"
     1548    !  ----------------------------------------
     1549
     1550    print *, 'dtime, tau ', dtime, tau
     1551    print *, 't_targ', t_targ
     1552    print *, 'rh_targ', rh_targ
     1553    print *, 'temp ', t
     1554    print *, 'hum ', q
     1555
     1556    DO k = 1, klev
     1557      DO i = 1, klon
     1558        IF (paprs(i, 1) - pplay(i, k) > 10000.) THEN
     1559          IF (t(i, k)<RTT) THEN
     1560            zx_qs = qsats(t(i, k)) / (pplay(i, k))
     1561          ELSE
     1562            zx_qs = qsatl(t(i, k)) / (pplay(i, k))
     1563          ENDIF
     1564          rh = q(i, k) / zx_qs
     1565
     1566          d_t(i, k) = d_t(i, k) + 1. / tau * (t_targ(i, k) - t(i, k))
     1567          d_rh = 1. / tau * (rh_targ(i, k) - rh)
     1568
     1569          tnew = t(i, k) + d_t(i, k) * dtime
     1570          !jyg<
     1571          !   Formule pour q :
     1572          !                         d_q = (1/tau) [rh_targ*qsat(T_new) - q]
     1573
     1574          !  Cette formule remplace d_q = (1/tau) [rh_targ - rh] qsat(T_new)
     1575          !   qui n'etait pas correcte.
     1576
     1577          IF (tnew<RTT) THEN
     1578            zx_qs = qsats(tnew) / (pplay(i, k))
     1579          ELSE
     1580            zx_qs = qsatl(tnew) / (pplay(i, k))
     1581          ENDIF
     1582          !!            d_q(i,k) = d_q(i,k) + d_rh*zx_qs
     1583          d_q(i, k) = d_q(i, k) + (1. / tau) * (rh_targ(i, k) * zx_qs - q(i, k))
     1584          rhnew = (q(i, k) + d_q(i, k) * dtime) / zx_qs
     1585
     1586          print *, ' k,d_t,rh,d_rh,rhnew,d_q ', &
     1587                  k, d_t(i, k), rh, d_rh, rhnew, d_q(i, k)
    16341588        ENDIF
    1635         !!            d_q(i,k) = d_q(i,k) + d_rh*zx_qs
    1636         d_q(i, k) = d_q(i, k) + (1. / tau) * (rh_targ(i, k) * zx_qs - q(i, k))
    1637         rhnew = (q(i, k) + d_q(i, k) * dtime) / zx_qs
    1638 
    1639         print *, ' k,d_t,rh,d_rh,rhnew,d_q ', &
    1640                 k, d_t(i, k), rh, d_rh, rhnew, d_q(i, k)
    1641       ENDIF
    1642 
     1589
     1590      ENDDO
    16431591    ENDDO
    1644   ENDDO
    1645 
    1646   RETURN
    1647 END
    1648 
    1649 Subroutine Nudge_UV (dtime, paprs, pplay, u_targ, v_targ, u, v, &
    1650         &                      d_u, d_v)
    1651   ! ========================================================
    1652   USE dimphy
    1653 
    1654   implicit none
    1655 
    1656   ! ========================================================
    1657   REAL dtime
    1658   REAL paprs(klon, klevp1)
    1659   REAL pplay(klon, klev)
    1660 
    1661   !      Variables d'etat
    1662   REAL u(klon, klev)
    1663   REAL v(klon, klev)
    1664 
    1665   ! Tendances
    1666   REAL d_u(klon, klev)
    1667   REAL d_v(klon, klev)
    1668 
    1669   !   Profiles cible
    1670   REAL u_targ(klon, klev)
    1671   REAL v_targ(klon, klev)
    1672 
    1673   !   Temps de relaxation
    1674   REAL tau
    1675   !c      DATA tau /3600./
    1676   !      DATA tau /5400./
    1677   DATA tau /43200./
    1678 
    1679   INTEGER k, i
    1680 
    1681   !print *,'dtime, tau ',dtime,tau
    1682   !print *, 'u_targ',u_targ
    1683   !print *, 'v_targ',v_targ
    1684   !print *,'zonal velocity ',u
    1685   !print *,'meridional velocity ',v
    1686   DO k = 1, klev
    1687     DO i = 1, klon
    1688       !CR: nudging everywhere
    1689       !           IF (paprs(i,1)-pplay(i,k) .GT. 10000.) THEN
    1690 
    1691       d_u(i, k) = d_u(i, k) + 1. / tau * (u_targ(i, k) - u(i, k))
    1692       d_v(i, k) = d_v(i, k) + 1. / tau * (v_targ(i, k) - v(i, k))
    1693 
    1694       !           print *,' k,u,d_u,v,d_v ',    &
    1695       !                     k,u(i,k),d_u(i,k),v(i,k),d_v(i,k)
    1696       !           ENDIF
    1697 
     1592
     1593    RETURN
     1594  END
     1595
     1596  Subroutine Nudge_UV (dtime, paprs, pplay, u_targ, v_targ, u, v, &
     1597          &                      d_u, d_v)
     1598    ! ========================================================
     1599    USE dimphy
     1600
     1601    implicit none
     1602
     1603    ! ========================================================
     1604    REAL dtime
     1605    REAL paprs(klon, klevp1)
     1606    REAL pplay(klon, klev)
     1607
     1608    !      Variables d'etat
     1609    REAL u(klon, klev)
     1610    REAL v(klon, klev)
     1611
     1612    ! Tendances
     1613    REAL d_u(klon, klev)
     1614    REAL d_v(klon, klev)
     1615
     1616    !   Profiles cible
     1617    REAL u_targ(klon, klev)
     1618    REAL v_targ(klon, klev)
     1619
     1620    !   Temps de relaxation
     1621    REAL tau
     1622    !c      DATA tau /3600./
     1623    !      DATA tau /5400./
     1624    DATA tau /43200./
     1625
     1626    INTEGER k, i
     1627
     1628    !print *,'dtime, tau ',dtime,tau
     1629    !print *, 'u_targ',u_targ
     1630    !print *, 'v_targ',v_targ
     1631    !print *,'zonal velocity ',u
     1632    !print *,'meridional velocity ',v
     1633    DO k = 1, klev
     1634      DO i = 1, klon
     1635        !CR: nudging everywhere
     1636        !           IF (paprs(i,1)-pplay(i,k) .GT. 10000.) THEN
     1637
     1638        d_u(i, k) = d_u(i, k) + 1. / tau * (u_targ(i, k) - u(i, k))
     1639        d_v(i, k) = d_v(i, k) + 1. / tau * (v_targ(i, k) - v(i, k))
     1640
     1641        !           print *,' k,u,d_u,v,d_v ',    &
     1642        !                     k,u(i,k),d_u(i,k),v(i,k),d_v(i,k)
     1643        !           ENDIF
     1644
     1645      ENDDO
    16981646    ENDDO
    1699   ENDDO
    1700 
    1701   RETURN
    1702 END
    1703 
    1704 !=====================================================================
    1705 SUBROUTINE interp2_case_vertical(play, nlev_cas, plev_prof_cas                                    &
    1706         &, t_prof_cas, th_prof_cas, thv_prof_cas, thl_prof_cas                                       &
    1707         &, qv_prof_cas, ql_prof_cas, qi_prof_cas, u_prof_cas, v_prof_cas                              &
    1708         &, ug_prof_cas, vg_prof_cas, vitw_prof_cas, omega_prof_cas                                   &
    1709         &, du_prof_cas, hu_prof_cas, vu_prof_cas, dv_prof_cas, hv_prof_cas, vv_prof_cas                &
    1710         &, dt_prof_cas, ht_prof_cas, vt_prof_cas, dtrad_prof_cas, dq_prof_cas, hq_prof_cas, vq_prof_cas &
    1711         &, dth_prof_cas, hth_prof_cas, vth_prof_cas                                                 &
    1712 
    1713         &, t_mod_cas, theta_mod_cas, thv_mod_cas, thl_mod_cas                                        &
    1714         &, qv_mod_cas, ql_mod_cas, qi_mod_cas, u_mod_cas, v_mod_cas                                   &
    1715         &, ug_mod_cas, vg_mod_cas, w_mod_cas, omega_mod_cas                                          &
    1716         &, du_mod_cas, hu_mod_cas, vu_mod_cas, dv_mod_cas, hv_mod_cas, vv_mod_cas                      &
    1717         &, dt_mod_cas, ht_mod_cas, vt_mod_cas, dtrad_mod_cas, dq_mod_cas, hq_mod_cas, vq_mod_cas        &
    1718         &, dth_mod_cas, hth_mod_cas, vth_mod_cas, mxcalc)
    1719 
    1720   implicit none
    1721 
    1722   include "YOMCST.h"
    1723   include "dimensions.h"
    1724 
    1725   !-------------------------------------------------------------------------
    1726   ! Vertical interpolation of generic case forcing data onto mod_casel levels
    1727   !-------------------------------------------------------------------------
    1728 
    1729   integer nlevmax
    1730   parameter (nlevmax = 41)
    1731   integer nlev_cas, mxcalc
    1732   !       real play(llm), plev_prof(nlevmax)
    1733   !       real t_prof(nlevmax),q_prof(nlevmax)
    1734   !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
    1735   !       real ht_prof(nlevmax),vt_prof(nlevmax)
    1736   !       real hq_prof(nlevmax),vq_prof(nlevmax)
    1737 
    1738   real play(llm), plev_prof_cas(nlev_cas)
    1739   real t_prof_cas(nlev_cas), th_prof_cas(nlev_cas), thv_prof_cas(nlev_cas), thl_prof_cas(nlev_cas)
    1740   real qv_prof_cas(nlev_cas), ql_prof_cas(nlev_cas), qi_prof_cas(nlev_cas)
    1741   real u_prof_cas(nlev_cas), v_prof_cas(nlev_cas)
    1742   real ug_prof_cas(nlev_cas), vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas), omega_prof_cas(nlev_cas)
    1743   real du_prof_cas(nlev_cas), hu_prof_cas(nlev_cas), vu_prof_cas(nlev_cas)
    1744   real dv_prof_cas(nlev_cas), hv_prof_cas(nlev_cas), vv_prof_cas(nlev_cas)
    1745   real dt_prof_cas(nlev_cas), ht_prof_cas(nlev_cas), vt_prof_cas(nlev_cas), dtrad_prof_cas(nlev_cas)
    1746   real dth_prof_cas(nlev_cas), hth_prof_cas(nlev_cas), vth_prof_cas(nlev_cas)
    1747   real dq_prof_cas(nlev_cas), hq_prof_cas(nlev_cas), vq_prof_cas(nlev_cas)
    1748 
    1749   real t_mod_cas(llm), theta_mod_cas(llm), thv_mod_cas(llm), thl_mod_cas(llm)
    1750   real qv_mod_cas(llm), ql_mod_cas(llm), qi_mod_cas(llm)
    1751   real u_mod_cas(llm), v_mod_cas(llm)
    1752   real ug_mod_cas(llm), vg_mod_cas(llm), w_mod_cas(llm), omega_mod_cas(llm)
    1753   real du_mod_cas(llm), hu_mod_cas(llm), vu_mod_cas(llm)
    1754   real dv_mod_cas(llm), hv_mod_cas(llm), vv_mod_cas(llm)
    1755   real dt_mod_cas(llm), ht_mod_cas(llm), vt_mod_cas(llm), dtrad_mod_cas(llm)
    1756   real dth_mod_cas(llm), hth_mod_cas(llm), vth_mod_cas(llm)
    1757   real dq_mod_cas(llm), hq_mod_cas(llm), vq_mod_cas(llm)
    1758 
    1759   integer l, k, k1, k2
    1760   real frac, frac1, frac2, fact
    1761 
    1762   !       do l = 1, llm
    1763   !       print *,'debut interp2, play=',l,play(l)
    1764   !       enddo
    1765   !      do l = 1, nlev_cas
    1766   !      print *,'debut interp2, plev_prof_cas=',l,play(l),plev_prof_cas(l)
    1767   !      enddo
    1768 
    1769   do l = 1, llm
    1770 
    1771     if (play(l)>=plev_prof_cas(nlev_cas)) then
    1772 
    1773       mxcalc = l
    1774       !        print *,'debut interp2, mxcalc=',mxcalc
    1775       k1 = 0
    1776       k2 = 0
    1777 
    1778       if (play(l)<=plev_prof_cas(1)) then
    1779 
    1780         do k = 1, nlev_cas - 1
    1781           if (play(l)<=plev_prof_cas(k).and. play(l)>plev_prof_cas(k + 1)) then
    1782             k1 = k
    1783             k2 = k + 1
     1647
     1648    RETURN
     1649  END
     1650
     1651  SUBROUTINE interp2_case_vertical(play, nlev_cas, plev_prof_cas                                    &
     1652          &, t_prof_cas, th_prof_cas, thv_prof_cas, thl_prof_cas                                       &
     1653          &, qv_prof_cas, ql_prof_cas, qi_prof_cas, u_prof_cas, v_prof_cas                              &
     1654          &, ug_prof_cas, vg_prof_cas, vitw_prof_cas, omega_prof_cas                                   &
     1655          &, du_prof_cas, hu_prof_cas, vu_prof_cas, dv_prof_cas, hv_prof_cas, vv_prof_cas                &
     1656          &, dt_prof_cas, ht_prof_cas, vt_prof_cas, dtrad_prof_cas, dq_prof_cas, hq_prof_cas, vq_prof_cas &
     1657          &, dth_prof_cas, hth_prof_cas, vth_prof_cas                                                 &
     1658
     1659          &, t_mod_cas, theta_mod_cas, thv_mod_cas, thl_mod_cas                                        &
     1660          &, qv_mod_cas, ql_mod_cas, qi_mod_cas, u_mod_cas, v_mod_cas                                   &
     1661          &, ug_mod_cas, vg_mod_cas, w_mod_cas, omega_mod_cas                                          &
     1662          &, du_mod_cas, hu_mod_cas, vu_mod_cas, dv_mod_cas, hv_mod_cas, vv_mod_cas                      &
     1663          &, dt_mod_cas, ht_mod_cas, vt_mod_cas, dtrad_mod_cas, dq_mod_cas, hq_mod_cas, vq_mod_cas        &
     1664          &, dth_mod_cas, hth_mod_cas, vth_mod_cas, mxcalc)
     1665
     1666    implicit none
     1667
     1668    include "YOMCST.h"
     1669    include "dimensions.h"
     1670
     1671    !-------------------------------------------------------------------------
     1672    ! Vertical interpolation of generic case forcing data onto mod_casel levels
     1673    !-------------------------------------------------------------------------
     1674
     1675    integer nlevmax
     1676    parameter (nlevmax = 41)
     1677    integer nlev_cas, mxcalc
     1678    !       real play(llm), plev_prof(nlevmax)
     1679    !       real t_prof(nlevmax),q_prof(nlevmax)
     1680    !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
     1681    !       real ht_prof(nlevmax),vt_prof(nlevmax)
     1682    !       real hq_prof(nlevmax),vq_prof(nlevmax)
     1683
     1684    real play(llm), plev_prof_cas(nlev_cas)
     1685    real t_prof_cas(nlev_cas), th_prof_cas(nlev_cas), thv_prof_cas(nlev_cas), thl_prof_cas(nlev_cas)
     1686    real qv_prof_cas(nlev_cas), ql_prof_cas(nlev_cas), qi_prof_cas(nlev_cas)
     1687    real u_prof_cas(nlev_cas), v_prof_cas(nlev_cas)
     1688    real ug_prof_cas(nlev_cas), vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas), omega_prof_cas(nlev_cas)
     1689    real du_prof_cas(nlev_cas), hu_prof_cas(nlev_cas), vu_prof_cas(nlev_cas)
     1690    real dv_prof_cas(nlev_cas), hv_prof_cas(nlev_cas), vv_prof_cas(nlev_cas)
     1691    real dt_prof_cas(nlev_cas), ht_prof_cas(nlev_cas), vt_prof_cas(nlev_cas), dtrad_prof_cas(nlev_cas)
     1692    real dth_prof_cas(nlev_cas), hth_prof_cas(nlev_cas), vth_prof_cas(nlev_cas)
     1693    real dq_prof_cas(nlev_cas), hq_prof_cas(nlev_cas), vq_prof_cas(nlev_cas)
     1694
     1695    real t_mod_cas(llm), theta_mod_cas(llm), thv_mod_cas(llm), thl_mod_cas(llm)
     1696    real qv_mod_cas(llm), ql_mod_cas(llm), qi_mod_cas(llm)
     1697    real u_mod_cas(llm), v_mod_cas(llm)
     1698    real ug_mod_cas(llm), vg_mod_cas(llm), w_mod_cas(llm), omega_mod_cas(llm)
     1699    real du_mod_cas(llm), hu_mod_cas(llm), vu_mod_cas(llm)
     1700    real dv_mod_cas(llm), hv_mod_cas(llm), vv_mod_cas(llm)
     1701    real dt_mod_cas(llm), ht_mod_cas(llm), vt_mod_cas(llm), dtrad_mod_cas(llm)
     1702    real dth_mod_cas(llm), hth_mod_cas(llm), vth_mod_cas(llm)
     1703    real dq_mod_cas(llm), hq_mod_cas(llm), vq_mod_cas(llm)
     1704
     1705    integer l, k, k1, k2
     1706    real frac, frac1, frac2, fact
     1707
     1708    !       do l = 1, llm
     1709    !       print *,'debut interp2, play=',l,play(l)
     1710    !       enddo
     1711    !      do l = 1, nlev_cas
     1712    !      print *,'debut interp2, plev_prof_cas=',l,play(l),plev_prof_cas(l)
     1713    !      enddo
     1714
     1715    do l = 1, llm
     1716
     1717      if (play(l)>=plev_prof_cas(nlev_cas)) then
     1718
     1719        mxcalc = l
     1720        !        print *,'debut interp2, mxcalc=',mxcalc
     1721        k1 = 0
     1722        k2 = 0
     1723
     1724        if (play(l)<=plev_prof_cas(1)) then
     1725
     1726          do k = 1, nlev_cas - 1
     1727            if (play(l)<=plev_prof_cas(k).and. play(l)>plev_prof_cas(k + 1)) then
     1728              k1 = k
     1729              k2 = k + 1
     1730            endif
     1731          enddo
     1732
     1733          if (k1==0 .or. k2==0) then
     1734            write(*, *) 'PB! k1, k2 = ', k1, k2
     1735            write(*, *) 'l,play(l) = ', l, play(l) / 100
     1736            do k = 1, nlev_cas - 1
     1737              write(*, *) 'k,plev_prof_cas(k) = ', k, plev_prof_cas(k) / 100
     1738            enddo
    17841739          endif
    1785         enddo
    1786 
    1787         if (k1==0 .or. k2==0) then
    1788           write(*, *) 'PB! k1, k2 = ', k1, k2
    1789           write(*, *) 'l,play(l) = ', l, play(l) / 100
    1790           do k = 1, nlev_cas - 1
    1791             write(*, *) 'k,plev_prof_cas(k) = ', k, plev_prof_cas(k) / 100
    1792           enddo
    1793         endif
    1794 
    1795         frac = (plev_prof_cas(k2) - play(l)) / (plev_prof_cas(k2) - plev_prof_cas(k1))
    1796         t_mod_cas(l) = t_prof_cas(k2) - frac * (t_prof_cas(k2) - t_prof_cas(k1))
    1797         theta_mod_cas(l) = th_prof_cas(k2) - frac * (th_prof_cas(k2) - th_prof_cas(k1))
    1798         if(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
    1799         thv_mod_cas(l) = thv_prof_cas(k2) - frac * (thv_prof_cas(k2) - thv_prof_cas(k1))
    1800         thl_mod_cas(l) = thl_prof_cas(k2) - frac * (thl_prof_cas(k2) - thl_prof_cas(k1))
    1801         qv_mod_cas(l) = qv_prof_cas(k2) - frac * (qv_prof_cas(k2) - qv_prof_cas(k1))
    1802         ql_mod_cas(l) = ql_prof_cas(k2) - frac * (ql_prof_cas(k2) - ql_prof_cas(k1))
    1803         qi_mod_cas(l) = qi_prof_cas(k2) - frac * (qi_prof_cas(k2) - qi_prof_cas(k1))
    1804         u_mod_cas(l) = u_prof_cas(k2) - frac * (u_prof_cas(k2) - u_prof_cas(k1))
    1805         v_mod_cas(l) = v_prof_cas(k2) - frac * (v_prof_cas(k2) - v_prof_cas(k1))
    1806         ug_mod_cas(l) = ug_prof_cas(k2) - frac * (ug_prof_cas(k2) - ug_prof_cas(k1))
    1807         vg_mod_cas(l) = vg_prof_cas(k2) - frac * (vg_prof_cas(k2) - vg_prof_cas(k1))
    1808         w_mod_cas(l) = vitw_prof_cas(k2) - frac * (vitw_prof_cas(k2) - vitw_prof_cas(k1))
    1809         omega_mod_cas(l) = omega_prof_cas(k2) - frac * (omega_prof_cas(k2) - omega_prof_cas(k1))
    1810         du_mod_cas(l) = du_prof_cas(k2) - frac * (du_prof_cas(k2) - du_prof_cas(k1))
    1811         hu_mod_cas(l) = hu_prof_cas(k2) - frac * (hu_prof_cas(k2) - hu_prof_cas(k1))
    1812         vu_mod_cas(l) = vu_prof_cas(k2) - frac * (vu_prof_cas(k2) - vu_prof_cas(k1))
    1813         dv_mod_cas(l) = dv_prof_cas(k2) - frac * (dv_prof_cas(k2) - dv_prof_cas(k1))
    1814         hv_mod_cas(l) = hv_prof_cas(k2) - frac * (hv_prof_cas(k2) - hv_prof_cas(k1))
    1815         vv_mod_cas(l) = vv_prof_cas(k2) - frac * (vv_prof_cas(k2) - vv_prof_cas(k1))
    1816         dt_mod_cas(l) = dt_prof_cas(k2) - frac * (dt_prof_cas(k2) - dt_prof_cas(k1))
    1817         ht_mod_cas(l) = ht_prof_cas(k2) - frac * (ht_prof_cas(k2) - ht_prof_cas(k1))
    1818         vt_mod_cas(l) = vt_prof_cas(k2) - frac * (vt_prof_cas(k2) - vt_prof_cas(k1))
    1819         dth_mod_cas(l) = dth_prof_cas(k2) - frac * (dth_prof_cas(k2) - dth_prof_cas(k1))
    1820         hth_mod_cas(l) = hth_prof_cas(k2) - frac * (hth_prof_cas(k2) - hth_prof_cas(k1))
    1821         vth_mod_cas(l) = vth_prof_cas(k2) - frac * (vth_prof_cas(k2) - vth_prof_cas(k1))
    1822         dq_mod_cas(l) = dq_prof_cas(k2) - frac * (dq_prof_cas(k2) - dq_prof_cas(k1))
    1823         hq_mod_cas(l) = hq_prof_cas(k2) - frac * (hq_prof_cas(k2) - hq_prof_cas(k1))
    1824         vq_mod_cas(l) = vq_prof_cas(k2) - frac * (vq_prof_cas(k2) - vq_prof_cas(k1))
    1825         dtrad_mod_cas(l) = dtrad_prof_cas(k2) - frac * (dtrad_prof_cas(k2) - dtrad_prof_cas(k1))
    1826 
    1827       else !play>plev_prof_cas(1)
    1828 
    1829         k1 = 1
    1830         k2 = 2
    1831         print *, 'interp2_vert, k1,k2=', plev_prof_cas(k1), plev_prof_cas(k2)
    1832         frac1 = (play(l) - plev_prof_cas(k2)) / (plev_prof_cas(k1) - plev_prof_cas(k2))
    1833         frac2 = (play(l) - plev_prof_cas(k1)) / (plev_prof_cas(k1) - plev_prof_cas(k2))
    1834         t_mod_cas(l) = frac1 * t_prof_cas(k1) - frac2 * t_prof_cas(k2)
    1835         theta_mod_cas(l) = frac1 * th_prof_cas(k1) - frac2 * th_prof_cas(k2)
    1836         if(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
    1837         thv_mod_cas(l) = frac1 * thv_prof_cas(k1) - frac2 * thv_prof_cas(k2)
    1838         thl_mod_cas(l) = frac1 * thl_prof_cas(k1) - frac2 * thl_prof_cas(k2)
    1839         qv_mod_cas(l) = frac1 * qv_prof_cas(k1) - frac2 * qv_prof_cas(k2)
    1840         ql_mod_cas(l) = frac1 * ql_prof_cas(k1) - frac2 * ql_prof_cas(k2)
    1841         qi_mod_cas(l) = frac1 * qi_prof_cas(k1) - frac2 * qi_prof_cas(k2)
    1842         u_mod_cas(l) = frac1 * u_prof_cas(k1) - frac2 * u_prof_cas(k2)
    1843         v_mod_cas(l) = frac1 * v_prof_cas(k1) - frac2 * v_prof_cas(k2)
    1844         ug_mod_cas(l) = frac1 * ug_prof_cas(k1) - frac2 * ug_prof_cas(k2)
    1845         vg_mod_cas(l) = frac1 * vg_prof_cas(k1) - frac2 * vg_prof_cas(k2)
    1846         w_mod_cas(l) = frac1 * vitw_prof_cas(k1) - frac2 * vitw_prof_cas(k2)
    1847         omega_mod_cas(l) = frac1 * omega_prof_cas(k1) - frac2 * omega_prof_cas(k2)
    1848         du_mod_cas(l) = frac1 * du_prof_cas(k1) - frac2 * du_prof_cas(k2)
    1849         hu_mod_cas(l) = frac1 * hu_prof_cas(k1) - frac2 * hu_prof_cas(k2)
    1850         vu_mod_cas(l) = frac1 * vu_prof_cas(k1) - frac2 * vu_prof_cas(k2)
    1851         dv_mod_cas(l) = frac1 * dv_prof_cas(k1) - frac2 * dv_prof_cas(k2)
    1852         hv_mod_cas(l) = frac1 * hv_prof_cas(k1) - frac2 * hv_prof_cas(k2)
    1853         vv_mod_cas(l) = frac1 * vv_prof_cas(k1) - frac2 * vv_prof_cas(k2)
    1854         dt_mod_cas(l) = frac1 * dt_prof_cas(k1) - frac2 * dt_prof_cas(k2)
    1855         ht_mod_cas(l) = frac1 * ht_prof_cas(k1) - frac2 * ht_prof_cas(k2)
    1856         vt_mod_cas(l) = frac1 * vt_prof_cas(k1) - frac2 * vt_prof_cas(k2)
    1857         dth_mod_cas(l) = frac1 * dth_prof_cas(k1) - frac2 * dth_prof_cas(k2)
    1858         hth_mod_cas(l) = frac1 * hth_prof_cas(k1) - frac2 * hth_prof_cas(k2)
    1859         vth_mod_cas(l) = frac1 * vth_prof_cas(k1) - frac2 * vth_prof_cas(k2)
    1860         dq_mod_cas(l) = frac1 * dq_prof_cas(k1) - frac2 * dq_prof_cas(k2)
    1861         hq_mod_cas(l) = frac1 * hq_prof_cas(k1) - frac2 * hq_prof_cas(k2)
    1862         vq_mod_cas(l) = frac1 * vq_prof_cas(k1) - frac2 * vq_prof_cas(k2)
    1863         dtrad_mod_cas(l) = frac1 * dtrad_prof_cas(k1) - frac2 * dtrad_prof_cas(k2)
    1864 
    1865       endif ! play.le.plev_prof_cas(1)
    1866 
    1867     else ! above max altitude of forcing file
    1868 
    1869       !jyg
    1870       fact = 20. * (plev_prof_cas(nlev_cas) - play(l)) / plev_prof_cas(nlev_cas) !jyg
    1871       fact = max(fact, 0.)                                           !jyg
    1872       fact = exp(-fact)                                             !jyg
    1873       t_mod_cas(l) = t_prof_cas(nlev_cas)                            !jyg
    1874       theta_mod_cas(l) = th_prof_cas(nlev_cas)                       !jyg
    1875       thv_mod_cas(l) = thv_prof_cas(nlev_cas)                        !jyg
    1876       thl_mod_cas(l) = thl_prof_cas(nlev_cas)                        !jyg
    1877       qv_mod_cas(l) = qv_prof_cas(nlev_cas) * fact                     !jyg
    1878       ql_mod_cas(l) = ql_prof_cas(nlev_cas) * fact                     !jyg
    1879       qi_mod_cas(l) = qi_prof_cas(nlev_cas) * fact                     !jyg
    1880       u_mod_cas(l) = u_prof_cas(nlev_cas) * fact                       !jyg
    1881       v_mod_cas(l) = v_prof_cas(nlev_cas) * fact                       !jyg
    1882       ug_mod_cas(l) = ug_prof_cas(nlev_cas) * fact                     !jyg
    1883       vg_mod_cas(l) = vg_prof_cas(nlev_cas) * fact                     !jyg
    1884       w_mod_cas(l) = 0.0                                             !jyg
    1885       omega_mod_cas(l) = 0.0                                         !jyg
    1886       du_mod_cas(l) = du_prof_cas(nlev_cas) * fact
    1887       hu_mod_cas(l) = hu_prof_cas(nlev_cas) * fact                     !jyg
    1888       vu_mod_cas(l) = vu_prof_cas(nlev_cas) * fact                     !jyg
    1889       dv_mod_cas(l) = dv_prof_cas(nlev_cas) * fact
    1890       hv_mod_cas(l) = hv_prof_cas(nlev_cas) * fact                     !jyg
    1891       vv_mod_cas(l) = vv_prof_cas(nlev_cas) * fact                     !jyg
    1892       dt_mod_cas(l) = dt_prof_cas(nlev_cas)
    1893       ht_mod_cas(l) = ht_prof_cas(nlev_cas)                          !jyg
    1894       vt_mod_cas(l) = vt_prof_cas(nlev_cas)                          !jyg
    1895       dth_mod_cas(l) = dth_prof_cas(nlev_cas)
    1896       hth_mod_cas(l) = hth_prof_cas(nlev_cas)                        !jyg
    1897       vth_mod_cas(l) = vth_prof_cas(nlev_cas)                        !jyg
    1898       dq_mod_cas(l) = dq_prof_cas(nlev_cas) * fact
    1899       hq_mod_cas(l) = hq_prof_cas(nlev_cas) * fact                     !jyg
    1900       vq_mod_cas(l) = vq_prof_cas(nlev_cas) * fact                     !jyg
    1901       dtrad_mod_cas(l) = dtrad_prof_cas(nlev_cas) * fact               !jyg
    1902 
    1903     endif ! play
    1904 
    1905   enddo ! l
    1906 
    1907   return
    1908 end
    1909 !*****************************************************************************
    1910 
    1911 
    1912 
    1913 
     1740
     1741          frac = (plev_prof_cas(k2) - play(l)) / (plev_prof_cas(k2) - plev_prof_cas(k1))
     1742          t_mod_cas(l) = t_prof_cas(k2) - frac * (t_prof_cas(k2) - t_prof_cas(k1))
     1743          theta_mod_cas(l) = th_prof_cas(k2) - frac * (th_prof_cas(k2) - th_prof_cas(k1))
     1744          if(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
     1745          thv_mod_cas(l) = thv_prof_cas(k2) - frac * (thv_prof_cas(k2) - thv_prof_cas(k1))
     1746          thl_mod_cas(l) = thl_prof_cas(k2) - frac * (thl_prof_cas(k2) - thl_prof_cas(k1))
     1747          qv_mod_cas(l) = qv_prof_cas(k2) - frac * (qv_prof_cas(k2) - qv_prof_cas(k1))
     1748          ql_mod_cas(l) = ql_prof_cas(k2) - frac * (ql_prof_cas(k2) - ql_prof_cas(k1))
     1749          qi_mod_cas(l) = qi_prof_cas(k2) - frac * (qi_prof_cas(k2) - qi_prof_cas(k1))
     1750          u_mod_cas(l) = u_prof_cas(k2) - frac * (u_prof_cas(k2) - u_prof_cas(k1))
     1751          v_mod_cas(l) = v_prof_cas(k2) - frac * (v_prof_cas(k2) - v_prof_cas(k1))
     1752          ug_mod_cas(l) = ug_prof_cas(k2) - frac * (ug_prof_cas(k2) - ug_prof_cas(k1))
     1753          vg_mod_cas(l) = vg_prof_cas(k2) - frac * (vg_prof_cas(k2) - vg_prof_cas(k1))
     1754          w_mod_cas(l) = vitw_prof_cas(k2) - frac * (vitw_prof_cas(k2) - vitw_prof_cas(k1))
     1755          omega_mod_cas(l) = omega_prof_cas(k2) - frac * (omega_prof_cas(k2) - omega_prof_cas(k1))
     1756          du_mod_cas(l) = du_prof_cas(k2) - frac * (du_prof_cas(k2) - du_prof_cas(k1))
     1757          hu_mod_cas(l) = hu_prof_cas(k2) - frac * (hu_prof_cas(k2) - hu_prof_cas(k1))
     1758          vu_mod_cas(l) = vu_prof_cas(k2) - frac * (vu_prof_cas(k2) - vu_prof_cas(k1))
     1759          dv_mod_cas(l) = dv_prof_cas(k2) - frac * (dv_prof_cas(k2) - dv_prof_cas(k1))
     1760          hv_mod_cas(l) = hv_prof_cas(k2) - frac * (hv_prof_cas(k2) - hv_prof_cas(k1))
     1761          vv_mod_cas(l) = vv_prof_cas(k2) - frac * (vv_prof_cas(k2) - vv_prof_cas(k1))
     1762          dt_mod_cas(l) = dt_prof_cas(k2) - frac * (dt_prof_cas(k2) - dt_prof_cas(k1))
     1763          ht_mod_cas(l) = ht_prof_cas(k2) - frac * (ht_prof_cas(k2) - ht_prof_cas(k1))
     1764          vt_mod_cas(l) = vt_prof_cas(k2) - frac * (vt_prof_cas(k2) - vt_prof_cas(k1))
     1765          dth_mod_cas(l) = dth_prof_cas(k2) - frac * (dth_prof_cas(k2) - dth_prof_cas(k1))
     1766          hth_mod_cas(l) = hth_prof_cas(k2) - frac * (hth_prof_cas(k2) - hth_prof_cas(k1))
     1767          vth_mod_cas(l) = vth_prof_cas(k2) - frac * (vth_prof_cas(k2) - vth_prof_cas(k1))
     1768          dq_mod_cas(l) = dq_prof_cas(k2) - frac * (dq_prof_cas(k2) - dq_prof_cas(k1))
     1769          hq_mod_cas(l) = hq_prof_cas(k2) - frac * (hq_prof_cas(k2) - hq_prof_cas(k1))
     1770          vq_mod_cas(l) = vq_prof_cas(k2) - frac * (vq_prof_cas(k2) - vq_prof_cas(k1))
     1771          dtrad_mod_cas(l) = dtrad_prof_cas(k2) - frac * (dtrad_prof_cas(k2) - dtrad_prof_cas(k1))
     1772
     1773        else !play>plev_prof_cas(1)
     1774
     1775          k1 = 1
     1776          k2 = 2
     1777          print *, 'interp2_vert, k1,k2=', plev_prof_cas(k1), plev_prof_cas(k2)
     1778          frac1 = (play(l) - plev_prof_cas(k2)) / (plev_prof_cas(k1) - plev_prof_cas(k2))
     1779          frac2 = (play(l) - plev_prof_cas(k1)) / (plev_prof_cas(k1) - plev_prof_cas(k2))
     1780          t_mod_cas(l) = frac1 * t_prof_cas(k1) - frac2 * t_prof_cas(k2)
     1781          theta_mod_cas(l) = frac1 * th_prof_cas(k1) - frac2 * th_prof_cas(k2)
     1782          if(theta_mod_cas(l)/=0) t_mod_cas(l) = theta_mod_cas(l) * (play(l) / 100000.)**(RD / RCPD)
     1783          thv_mod_cas(l) = frac1 * thv_prof_cas(k1) - frac2 * thv_prof_cas(k2)
     1784          thl_mod_cas(l) = frac1 * thl_prof_cas(k1) - frac2 * thl_prof_cas(k2)
     1785          qv_mod_cas(l) = frac1 * qv_prof_cas(k1) - frac2 * qv_prof_cas(k2)
     1786          ql_mod_cas(l) = frac1 * ql_prof_cas(k1) - frac2 * ql_prof_cas(k2)
     1787          qi_mod_cas(l) = frac1 * qi_prof_cas(k1) - frac2 * qi_prof_cas(k2)
     1788          u_mod_cas(l) = frac1 * u_prof_cas(k1) - frac2 * u_prof_cas(k2)
     1789          v_mod_cas(l) = frac1 * v_prof_cas(k1) - frac2 * v_prof_cas(k2)
     1790          ug_mod_cas(l) = frac1 * ug_prof_cas(k1) - frac2 * ug_prof_cas(k2)
     1791          vg_mod_cas(l) = frac1 * vg_prof_cas(k1) - frac2 * vg_prof_cas(k2)
     1792          w_mod_cas(l) = frac1 * vitw_prof_cas(k1) - frac2 * vitw_prof_cas(k2)
     1793          omega_mod_cas(l) = frac1 * omega_prof_cas(k1) - frac2 * omega_prof_cas(k2)
     1794          du_mod_cas(l) = frac1 * du_prof_cas(k1) - frac2 * du_prof_cas(k2)
     1795          hu_mod_cas(l) = frac1 * hu_prof_cas(k1) - frac2 * hu_prof_cas(k2)
     1796          vu_mod_cas(l) = frac1 * vu_prof_cas(k1) - frac2 * vu_prof_cas(k2)
     1797          dv_mod_cas(l) = frac1 * dv_prof_cas(k1) - frac2 * dv_prof_cas(k2)
     1798          hv_mod_cas(l) = frac1 * hv_prof_cas(k1) - frac2 * hv_prof_cas(k2)
     1799          vv_mod_cas(l) = frac1 * vv_prof_cas(k1) - frac2 * vv_prof_cas(k2)
     1800          dt_mod_cas(l) = frac1 * dt_prof_cas(k1) - frac2 * dt_prof_cas(k2)
     1801          ht_mod_cas(l) = frac1 * ht_prof_cas(k1) - frac2 * ht_prof_cas(k2)
     1802          vt_mod_cas(l) = frac1 * vt_prof_cas(k1) - frac2 * vt_prof_cas(k2)
     1803          dth_mod_cas(l) = frac1 * dth_prof_cas(k1) - frac2 * dth_prof_cas(k2)
     1804          hth_mod_cas(l) = frac1 * hth_prof_cas(k1) - frac2 * hth_prof_cas(k2)
     1805          vth_mod_cas(l) = frac1 * vth_prof_cas(k1) - frac2 * vth_prof_cas(k2)
     1806          dq_mod_cas(l) = frac1 * dq_prof_cas(k1) - frac2 * dq_prof_cas(k2)
     1807          hq_mod_cas(l) = frac1 * hq_prof_cas(k1) - frac2 * hq_prof_cas(k2)
     1808          vq_mod_cas(l) = frac1 * vq_prof_cas(k1) - frac2 * vq_prof_cas(k2)
     1809          dtrad_mod_cas(l) = frac1 * dtrad_prof_cas(k1) - frac2 * dtrad_prof_cas(k2)
     1810
     1811        endif ! play.le.plev_prof_cas(1)
     1812
     1813      else ! above max altitude of forcing file
     1814
     1815        !jyg
     1816        fact = 20. * (plev_prof_cas(nlev_cas) - play(l)) / plev_prof_cas(nlev_cas) !jyg
     1817        fact = max(fact, 0.)                                           !jyg
     1818        fact = exp(-fact)                                             !jyg
     1819        t_mod_cas(l) = t_prof_cas(nlev_cas)                            !jyg
     1820        theta_mod_cas(l) = th_prof_cas(nlev_cas)                       !jyg
     1821        thv_mod_cas(l) = thv_prof_cas(nlev_cas)                        !jyg
     1822        thl_mod_cas(l) = thl_prof_cas(nlev_cas)                        !jyg
     1823        qv_mod_cas(l) = qv_prof_cas(nlev_cas) * fact                     !jyg
     1824        ql_mod_cas(l) = ql_prof_cas(nlev_cas) * fact                     !jyg
     1825        qi_mod_cas(l) = qi_prof_cas(nlev_cas) * fact                     !jyg
     1826        u_mod_cas(l) = u_prof_cas(nlev_cas) * fact                       !jyg
     1827        v_mod_cas(l) = v_prof_cas(nlev_cas) * fact                       !jyg
     1828        ug_mod_cas(l) = ug_prof_cas(nlev_cas) * fact                     !jyg
     1829        vg_mod_cas(l) = vg_prof_cas(nlev_cas) * fact                     !jyg
     1830        w_mod_cas(l) = 0.0                                             !jyg
     1831        omega_mod_cas(l) = 0.0                                         !jyg
     1832        du_mod_cas(l) = du_prof_cas(nlev_cas) * fact
     1833        hu_mod_cas(l) = hu_prof_cas(nlev_cas) * fact                     !jyg
     1834        vu_mod_cas(l) = vu_prof_cas(nlev_cas) * fact                     !jyg
     1835        dv_mod_cas(l) = dv_prof_cas(nlev_cas) * fact
     1836        hv_mod_cas(l) = hv_prof_cas(nlev_cas) * fact                     !jyg
     1837        vv_mod_cas(l) = vv_prof_cas(nlev_cas) * fact                     !jyg
     1838        dt_mod_cas(l) = dt_prof_cas(nlev_cas)
     1839        ht_mod_cas(l) = ht_prof_cas(nlev_cas)                          !jyg
     1840        vt_mod_cas(l) = vt_prof_cas(nlev_cas)                          !jyg
     1841        dth_mod_cas(l) = dth_prof_cas(nlev_cas)
     1842        hth_mod_cas(l) = hth_prof_cas(nlev_cas)                        !jyg
     1843        vth_mod_cas(l) = vth_prof_cas(nlev_cas)                        !jyg
     1844        dq_mod_cas(l) = dq_prof_cas(nlev_cas) * fact
     1845        hq_mod_cas(l) = hq_prof_cas(nlev_cas) * fact                     !jyg
     1846        vq_mod_cas(l) = vq_prof_cas(nlev_cas) * fact                     !jyg
     1847        dtrad_mod_cas(l) = dtrad_prof_cas(nlev_cas) * fact               !jyg
     1848
     1849      endif ! play
     1850
     1851    enddo ! l
     1852
     1853    return
     1854  end
     1855
     1856END MODULE lmdz_1dutils

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_old_1dconv.f90

    r5103 r5104  
    1 
    2 ! $Id$
    3 
    4         subroutine get_uvd(itap,dtime,file_forctl,file_fordat,                  &
    5      &       ht,hq,hw,hu,hv,hthturb,hqturb,                                     &
    6      &       Ts,imp_fcg,ts_fcg,Tp_fcg,Turb_fcg)                                 
    7 
    8         implicit none
    9  
    10 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    11 ! cette routine permet d obtenir u_convg,v_convg,ht,hq et ainsi de
    12 ! pouvoir calculer la convergence et le cisaillement dans la physiq
    13 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    14 
    15       INCLUDE "YOMCST.h"
    16 
    17       INTEGER klev
    18       REAL play(100)  !pression en Pa au milieu de chaque couche GCM
    19       INTEGER JM(100) !pression en Pa au milieu de chaque couche GCM
    20       REAL coef1(100) !coefficient d interpolation
    21       REAL coef2(100) !coefficient d interpolation
    22 
    23       INTEGER nblvlm !nombre de niveau de pression du mesoNH
    24       REAL playm(100)  !pression en Pa au milieu de chaque couche Meso-NH
    25       REAL hplaym(100) !pression en hPa milieux des couches Meso-NH
    26 
    27       integer i,j,k,ll,in
    28 
    29       CHARACTER*80 file_forctl,file_fordat
    30 
    31       COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
    32       COMMON/com2_phys_gcss/playm,hplaym,nblvlm
    33 
    34 !======================================================================
    35 ! methode: on va chercher les donnees du mesoNH de meteo france, on y
    36 !          a acces a tout pas detemps grace a la routine rdgrads qui
    37 !          est une boucle lisant dans ces fichiers.
    38 !          Puis on interpole ces donnes sur les 11 niveaux du gcm et
    39 !          et sur les pas de temps de ce meme gcm
    40 !----------------------------------------------------------------------
    41 ! input:
    42 !       pasmax     :nombre de pas de temps maximum du mesoNH
    43 !       dt         :pas de temps du meso_NH (en secondes)
    44 !----------------------------------------------------------------------
    45       integer pasmax,dt
    46       save pasmax,dt
    47 !----------------------------------------------------------------------
    48 ! arguments:
    49 !           itap   :compteur de la physique(le nombre de ces pas est
    50 !                   fixe dans la subroutine calcul_ini_gcm de interpo
    51 !                   -lation
    52 !           dtime  :pas detemps du gcm (en secondes)
    53 !           ht     :convergence horizontale de temperature(K/s)
    54 !           hq     :    "         "       d humidite (kg/kg/s)
    55 !           hw     :vitesse verticale moyenne (m/s**2)
    56 !           hu     :convergence horizontale d impulsion le long de x
    57 !                  (kg/(m^2 s^2)
    58 !           hv     : idem le long de y.
    59 !           Ts     : Temperature de surface (K)
    60 !           imp_fcg: var. logical .eq. T si forcage en impulsion
    61 !           ts_fcg: var. logical .eq. T si forcage en Ts present dans fichier
    62 !           Tp_fcg: var. logical .eq. T si forcage donne en Temp potentielle
    63 !           Turb_fcg: var. logical .eq. T si forcage turbulent present dans fichier
    64 !----------------------------------------------------------------------
    65         integer itap
    66         real dtime
    67         real ht(100)
    68         real hq(100)
    69         real hu(100)
    70         real hv(100)
    71         real hw(100)
    72         real hthturb(100)
    73         real hqturb(100)
    74         real Ts, Ts_subr
    75         logical imp_fcg
    76         logical ts_fcg
    77         logical Tp_fcg
    78         logical Turb_fcg
    79 !----------------------------------------------------------------------
    80 ! Variables internes de get_uvd (note : l interpolation temporelle
    81 ! est faite entre les pas de temps before et after, sur les variables
    82 ! definies sur la grille du SCM; on atteint exactement les valeurs Meso
    83 ! aux milieux des pas de temps Meso)
    84 !     time0     :date initiale en secondes
    85 !     time      :temps associe a chaque pas du SCM
    86 !     pas       :numero du pas du meso_NH (on lit en pas : le premier pas
    87 !                 des donnees est duplique)
    88 !     pasprev   :numero du pas de lecture precedent
    89 !     htaft     :advection horizontale de temp. au pas de temps after
    90 !     hqaft     :    "         "      d humidite        "
    91 !     hwaft     :vitesse verticalle moyenne  au pas de temps after
    92 !     huaft,hvaft :advection horizontale d impulsion au pas de temps after
    93 !     tsaft     : surface temperature 'after time step'
    94 !     htbef     :idem htaft, mais pour le pas de temps before
    95 !     hqbef     :voir hqaft
    96 !     hwbef     :voir hwaft
    97 !     hubef,hvbef : idem huaft,hvaft, mais pour before
    98 !     tsbef     : surface temperature 'before time step'
    99 !----------------------------------------------------------------------
    100         integer time0,pas,pasprev
    101         save time0,pas,pasprev
    102         real time
    103         real htaft(100),hqaft(100),hwaft(100),huaft(100),hvaft(100)
    104         real hthturbaft(100),hqturbaft(100)
    105         real Tsaft
    106         save htaft,hqaft,hwaft,huaft,hvaft,hthturbaft,hqturbaft
    107         real htbef(100),hqbef(100),hwbef(100),hubef(100),hvbef(100)
    108         real hthturbbef(100),hqturbbef(100)
    109         real Tsbef
    110         save htbef,hqbef,hwbef,hubef,hvbef,hthturbbef,hqturbbef
    111 
    112         real timeaft,timebef
    113         save timeaft,timebef
    114         integer temps
    115         character*4 string
    116 !----------------------------------------------------------------------
    117 ! variables arguments de la subroutine rdgrads
    118 !---------------------------------------------------------------------
    119         integer icompt,icomp1 !compteurs de rdgrads
    120         real z(100)         ! altitude (grille Meso)
    121         real ht_mes(100)    !convergence horizontale de temperature
    122                             !-(grille Meso)
    123         real hq_mes(100)    !convergence horizontale d humidite
    124                             !(grille Meso)
    125         real hw_mes(100)    !vitesse verticale moyenne
    126                             !(grille Meso)
    127         real hu_mes(100),hv_mes(100)    !convergence horizontale d impulsion
    128                                         !(grille Meso)
    129         real hthturb_mes(100) !tendance horizontale de T_pot, due aux
    130                               !flux turbulents
    131         real hqturb_mes(100) !tendance horizontale d humidite, due aux
    132                               !flux turbulents
    133 
    134 !---------------------------------------------------------------------
    135 ! variable argument de la subroutine copie
    136 !---------------------------------------------------------------------
    137 ! SB        real pplay(100)    !pression en milieu de couche du gcm
    138 ! SB                            !argument de la physique
    139 !---------------------------------------------------------------------
    140 ! variables destinees a la lecture du pas de temps du fichier de donnees
    141 !---------------------------------------------------------------------
    142        character*80 aaa,atemps,spaces,apasmax
    143        integer nch,imn,ipa
    144 !---------------------------------------------------------------------
    145 !  procedures appelees
    146         external rdgrads    !lire en iterant dans forcing.dat
    147 !---------------------------------------------------------------------
    148                PRINT*,'le pas itap est:',itap
    149 !*** on determine le pas du meso_NH correspondant au nouvel itap ***
    150 !*** pour aller chercher les champs dans rdgrads                 ***
    151 
    152         time=time0+itap*dtime
    153 !c        temps=int(time/dt+1)
    154 !c        pas=min(temps,pasmax)
    155         temps = 1 + int((dt + 2*time)/(2*dt))
    156         pas=min(temps,pasmax-1)
    157              PRINT*,'le pas Meso est:',pas
    158 
    159 
    160 !===================================================================
    161 
    162 !*** on remplit les champs before avec les champs after du pas   ***
    163 !*** precedent en format gcm                                     ***
    164         if(pas.gt.pasprev)then
    165           do i=1,klev
    166              htbef(i)=htaft(i)
    167              hqbef(i)=hqaft(i)
    168              hwbef(i)=hwaft(i)
    169              hubef(i)=huaft(i)
    170              hvbef(i)=hvaft(i)
    171              hThTurbbef(i)=hThTurbaft(i)
    172              hqTurbbef(i)=hqTurbaft(i)
    173           enddo
    174           tsbef = tsaft
    175           timebef=pasprev*dt
    176           timeaft=timebef+dt
    177           icomp1 = nblvlm*4
    178           IF (ts_fcg) icomp1 = icomp1 + 1
    179           IF (imp_fcg) icomp1 = icomp1 + nblvlm*2
    180           IF (Turb_fcg) icomp1 = icomp1 + nblvlm*2
    181           icompt = icomp1*pas
    182          print *, 'imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt'
    183          print *, imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt
    184                        PRINT*,'le pas pas est:',pas
    185 !*** on va chercher les nouveaux champs after dans toga.dat     ***
    186 !*** champs en format meso_NH                                   ***
    187           open(99,FILE=file_fordat,FORM='UNFORMATTED',                        &
    188      &             ACCESS='DIRECT',RECL=8)
    189           CALL rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes                &
    190      &                  ,hu_mes,hv_mes,hthturb_mes,hqturb_mes                 &
    191      &                  ,ts_fcg,ts_subr,imp_fcg,Turb_fcg)
    192 
    193                if(Tp_fcg) then
    194 !     (le forcage est donne en temperature potentielle)
    195          do i = 1,nblvlm
    196            ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa
    197          enddo
    198                endif ! Tp_fcg
     1MODULE lmdz_old_1dconv
     2  IMPLICIT NONE; PRIVATE
     3  PUBLIC get_uvd, copie
     4CONTAINS
     5
     6  subroutine get_uvd(itap, dtime, file_forctl, file_fordat, &
     7          &       ht, hq, hw, hu, hv, hthturb, hqturb, &
     8          &       Ts, imp_fcg, ts_fcg, Tp_fcg, Turb_fcg)
     9
     10    implicit none
     11
     12    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     13    ! cette routine permet d obtenir u_convg,v_convg,ht,hq et ainsi de
     14    ! pouvoir calculer la convergence et le cisaillement dans la physiq
     15    !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     16
     17    INCLUDE "YOMCST.h"
     18
     19    INTEGER klev
     20    REAL play(100)  !pression en Pa au milieu de chaque couche GCM
     21    INTEGER JM(100) !pression en Pa au milieu de chaque couche GCM
     22    REAL coef1(100) !coefficient d interpolation
     23    REAL coef2(100) !coefficient d interpolation
     24
     25    INTEGER nblvlm !nombre de niveau de pression du mesoNH
     26    REAL playm(100)  !pression en Pa au milieu de chaque couche Meso-NH
     27    REAL hplaym(100) !pression en hPa milieux des couches Meso-NH
     28
     29    integer i, j, k, ll, in
     30
     31    CHARACTER*80 file_forctl, file_fordat
     32
     33    COMMON/com1_phys_gcss/play, coef1, coef2, JM, klev
     34    COMMON/com2_phys_gcss/playm, hplaym, nblvlm
     35
     36    !======================================================================
     37    ! methode: on va chercher les donnees du mesoNH de meteo france, on y
     38    !          a acces a tout pas detemps grace a la routine rdgrads qui
     39    !          est une boucle lisant dans ces fichiers.
     40    !          Puis on interpole ces donnes sur les 11 niveaux du gcm et
     41    !          et sur les pas de temps de ce meme gcm
     42    !----------------------------------------------------------------------
     43    ! input:
     44    !       pasmax     :nombre de pas de temps maximum du mesoNH
     45    !       dt         :pas de temps du meso_NH (en secondes)
     46    !----------------------------------------------------------------------
     47    integer pasmax, dt
     48    save pasmax, dt
     49    !----------------------------------------------------------------------
     50    ! arguments:
     51    !           itap   :compteur de la physique(le nombre de ces pas est
     52    !                   fixe dans la subroutine calcul_ini_gcm de interpo
     53    !                   -lation
     54    !           dtime  :pas detemps du gcm (en secondes)
     55    !           ht     :convergence horizontale de temperature(K/s)
     56    !           hq     :    "         "       d humidite (kg/kg/s)
     57    !           hw     :vitesse verticale moyenne (m/s**2)
     58    !           hu     :convergence horizontale d impulsion le long de x
     59    !                  (kg/(m^2 s^2)
     60    !           hv     : idem le long de y.
     61    !           Ts     : Temperature de surface (K)
     62    !           imp_fcg: var. logical .eq. T si forcage en impulsion
     63    !           ts_fcg: var. logical .eq. T si forcage en Ts present dans fichier
     64    !           Tp_fcg: var. logical .eq. T si forcage donne en Temp potentielle
     65    !           Turb_fcg: var. logical .eq. T si forcage turbulent present dans fichier
     66    !----------------------------------------------------------------------
     67    integer itap
     68    real dtime
     69    real ht(100)
     70    real hq(100)
     71    real hu(100)
     72    real hv(100)
     73    real hw(100)
     74    real hthturb(100)
     75    real hqturb(100)
     76    real Ts, Ts_subr
     77    logical imp_fcg
     78    logical ts_fcg
     79    logical Tp_fcg
     80    logical Turb_fcg
     81    !----------------------------------------------------------------------
     82    ! Variables internes de get_uvd (note : l interpolation temporelle
     83    ! est faite entre les pas de temps before et after, sur les variables
     84    ! definies sur la grille du SCM; on atteint exactement les valeurs Meso
     85    ! aux milieux des pas de temps Meso)
     86    !     time0     :date initiale en secondes
     87    !     time      :temps associe a chaque pas du SCM
     88    !     pas       :numero du pas du meso_NH (on lit en pas : le premier pas
     89    !                 des donnees est duplique)
     90    !     pasprev   :numero du pas de lecture precedent
     91    !     htaft     :advection horizontale de temp. au pas de temps after
     92    !     hqaft     :    "         "      d humidite        "
     93    !     hwaft     :vitesse verticalle moyenne  au pas de temps after
     94    !     huaft,hvaft :advection horizontale d impulsion au pas de temps after
     95    !     tsaft     : surface temperature 'after time step'
     96    !     htbef     :idem htaft, mais pour le pas de temps before
     97    !     hqbef     :voir hqaft
     98    !     hwbef     :voir hwaft
     99    !     hubef,hvbef : idem huaft,hvaft, mais pour before
     100    !     tsbef     : surface temperature 'before time step'
     101    !----------------------------------------------------------------------
     102    integer time0, pas, pasprev
     103    save time0, pas, pasprev
     104    real time
     105    real htaft(100), hqaft(100), hwaft(100), huaft(100), hvaft(100)
     106    real hthturbaft(100), hqturbaft(100)
     107    real Tsaft
     108    save htaft, hqaft, hwaft, huaft, hvaft, hthturbaft, hqturbaft
     109    real htbef(100), hqbef(100), hwbef(100), hubef(100), hvbef(100)
     110    real hthturbbef(100), hqturbbef(100)
     111    real Tsbef
     112    save htbef, hqbef, hwbef, hubef, hvbef, hthturbbef, hqturbbef
     113
     114    real timeaft, timebef
     115    save timeaft, timebef
     116    integer temps
     117    character*4 string
     118    !----------------------------------------------------------------------
     119    ! variables arguments de la subroutine rdgrads
     120    !---------------------------------------------------------------------
     121    integer icompt, icomp1 !compteurs de rdgrads
     122    real z(100)         ! altitude (grille Meso)
     123    real ht_mes(100)    !convergence horizontale de temperature
     124    !-(grille Meso)
     125    real hq_mes(100)    !convergence horizontale d humidite
     126    !(grille Meso)
     127    real hw_mes(100)    !vitesse verticale moyenne
     128    !(grille Meso)
     129    real hu_mes(100), hv_mes(100)    !convergence horizontale d impulsion
     130    !(grille Meso)
     131    real hthturb_mes(100) !tendance horizontale de T_pot, due aux
     132    !flux turbulents
     133    real hqturb_mes(100) !tendance horizontale d humidite, due aux
     134    !flux turbulents
     135
     136    !---------------------------------------------------------------------
     137    ! variable argument de la subroutine copie
     138    !---------------------------------------------------------------------
     139    ! SB        real pplay(100)    !pression en milieu de couche du gcm
     140    ! SB                            !argument de la physique
     141    !---------------------------------------------------------------------
     142    ! variables destinees a la lecture du pas de temps du fichier de donnees
     143    !---------------------------------------------------------------------
     144    character*80 aaa, atemps, spaces, apasmax
     145    integer nch, imn, ipa
     146    !---------------------------------------------------------------------
     147    !  procedures appelees
     148    external rdgrads    !lire en iterant dans forcing.dat
     149    !---------------------------------------------------------------------
     150    PRINT*, 'le pas itap est:', itap
     151    !*** on determine le pas du meso_NH correspondant au nouvel itap ***
     152    !*** pour aller chercher les champs dans rdgrads                 ***
     153
     154    time = time0 + itap * dtime
     155    !c        temps=int(time/dt+1)
     156    !c        pas=min(temps,pasmax)
     157    temps = 1 + int((dt + 2 * time) / (2 * dt))
     158    pas = min(temps, pasmax - 1)
     159    PRINT*, 'le pas Meso est:', pas
     160
     161
     162    !===================================================================
     163
     164    !*** on remplit les champs before avec les champs after du pas   ***
     165    !*** precedent en format gcm                                     ***
     166    if(pas>pasprev)then
     167      do i = 1, klev
     168        htbef(i) = htaft(i)
     169        hqbef(i) = hqaft(i)
     170        hwbef(i) = hwaft(i)
     171        hubef(i) = huaft(i)
     172        hvbef(i) = hvaft(i)
     173        hThTurbbef(i) = hThTurbaft(i)
     174        hqTurbbef(i) = hqTurbaft(i)
     175      enddo
     176      tsbef = tsaft
     177      timebef = pasprev * dt
     178      timeaft = timebef + dt
     179      icomp1 = nblvlm * 4
     180      IF (ts_fcg) icomp1 = icomp1 + 1
     181      IF (imp_fcg) icomp1 = icomp1 + nblvlm * 2
     182      IF (Turb_fcg) icomp1 = icomp1 + nblvlm * 2
     183      icompt = icomp1 * pas
     184      print *, 'imp_fcg,ts_fcg,Turb_fcg,pas,nblvlm,icompt'
     185      print *, imp_fcg, ts_fcg, Turb_fcg, pas, nblvlm, icompt
     186      PRINT*, 'le pas pas est:', pas
     187      !*** on va chercher les nouveaux champs after dans toga.dat     ***
     188      !*** champs en format meso_NH                                   ***
     189      open(99, FILE = file_fordat, FORM = 'UNFORMATTED', &
     190              &             ACCESS = 'DIRECT', RECL = 8)
     191      CALL rdgrads(99, icompt, nblvlm, z, ht_mes, hq_mes, hw_mes                &
     192              &, hu_mes, hv_mes, hthturb_mes, hqturb_mes                 &
     193              &, ts_fcg, ts_subr, imp_fcg, Turb_fcg)
     194
     195      if(Tp_fcg) then
     196        !     (le forcage est donne en temperature potentielle)
     197        do i = 1, nblvlm
     198          ht_mes(i) = ht_mes(i) * (hplaym(i) / 1000.)**rkappa
     199        enddo
     200      endif ! Tp_fcg
     201      if(Turb_fcg) then
     202        do i = 1, nblvlm
     203          hThTurb_mes(i) = hThTurb_mes(i) * (hplaym(i) / 1000.)**rkappa
     204        enddo
     205      endif  ! Turb_fcg
     206
     207      PRINT*, 'ht_mes ', (ht_mes(i), i = 1, nblvlm)
     208      PRINT*, 'hq_mes ', (hq_mes(i), i = 1, nblvlm)
     209      PRINT*, 'hw_mes ', (hw_mes(i), i = 1, nblvlm)
     210      if(imp_fcg) then
     211        PRINT*, 'hu_mes ', (hu_mes(i), i = 1, nblvlm)
     212        PRINT*, 'hv_mes ', (hv_mes(i), i = 1, nblvlm)
     213      endif
     214      if(Turb_fcg) then
     215        PRINT*, 'hThTurb_mes ', (hThTurb_mes(i), i = 1, nblvlm)
     216        PRINT*, 'hqTurb_mes ', (hqTurb_mes(i), i = 1, nblvlm)
     217      endif
     218      IF (ts_fcg) PRINT*, 'ts_subr', ts_subr
     219      !*** on interpole les champs meso_NH sur les niveaux de pression***
     220      !*** gcm . on obtient le nouveau champ after                    ***
     221      do k = 1, klev
     222        if (JM(k) == 0) then
     223          htaft(k) = ht_mes(jm(k) + 1)
     224          hqaft(k) = hq_mes(jm(k) + 1)
     225          hwaft(k) = hw_mes(jm(k) + 1)
     226          if(imp_fcg) then
     227            huaft(k) = hu_mes(jm(k) + 1)
     228            hvaft(k) = hv_mes(jm(k) + 1)
     229          endif ! imp_fcg
     230          if(Turb_fcg) then
     231            hThTurbaft(k) = hThTurb_mes(jm(k) + 1)
     232            hqTurbaft(k) = hqTurb_mes(jm(k) + 1)
     233          endif ! Turb_fcg
     234        else ! JM(k) .eq. 0
     235          htaft(k) = coef1(k) * ht_mes(jm(k)) + coef2(k) * ht_mes(jm(k) + 1)
     236          hqaft(k) = coef1(k) * hq_mes(jm(k)) + coef2(k) * hq_mes(jm(k) + 1)
     237          hwaft(k) = coef1(k) * hw_mes(jm(k)) + coef2(k) * hw_mes(jm(k) + 1)
     238          if(imp_fcg) then
     239            huaft(k) = coef1(k) * hu_mes(jm(k)) + coef2(k) * hu_mes(jm(k) + 1)
     240            hvaft(k) = coef1(k) * hv_mes(jm(k)) + coef2(k) * hv_mes(jm(k) + 1)
     241          endif ! imp_fcg
     242          if(Turb_fcg) then
     243            hThTurbaft(k) = coef1(k) * hThTurb_mes(jm(k))                            &
     244                    & + coef2(k) * hThTurb_mes(jm(k) + 1)
     245            hqTurbaft(k) = coef1(k) * hqTurb_mes(jm(k))                             &
     246                    & + coef2(k) * hqTurb_mes(jm(k) + 1)
     247          endif ! Turb_fcg
     248        endif ! JM(k) .eq. 0
     249      enddo
     250      tsaft = ts_subr
     251      pasprev = pas
     252    else ! pas.gt.pasprev
     253      PRINT*, 'timebef est:', timebef
     254    endif ! pas.gt.pasprev    fin du bloc relatif au passage au pas
     255    !de temps (meso) suivant
     256    !*** si on atteint le pas max des donnees experimentales ,on     ***
     257    !*** on conserve les derniers champs calcules                    ***
     258    if(temps>=pasmax)then
     259      do ll = 1, klev
     260        ht(ll) = htaft(ll)
     261        hq(ll) = hqaft(ll)
     262        hw(ll) = hwaft(ll)
     263        hu(ll) = huaft(ll)
     264        hv(ll) = hvaft(ll)
     265        hThTurb(ll) = hThTurbaft(ll)
     266        hqTurb(ll) = hqTurbaft(ll)
     267      enddo
     268      ts_subr = tsaft
     269    else ! temps.ge.pasmax
     270      !*** on interpole sur les pas de temps de 10mn du gcm a partir   ***
     271      !** des pas de temps de 1h du meso_NH                            ***
     272      do j = 1, klev
     273        ht(j) = ((timeaft - time) * htbef(j) + (time - timebef) * htaft(j)) / dt
     274        hq(j) = ((timeaft - time) * hqbef(j) + (time - timebef) * hqaft(j)) / dt
     275        hw(j) = ((timeaft - time) * hwbef(j) + (time - timebef) * hwaft(j)) / dt
     276        if(imp_fcg) then
     277          hu(j) = ((timeaft - time) * hubef(j) + (time - timebef) * huaft(j)) / dt
     278          hv(j) = ((timeaft - time) * hvbef(j) + (time - timebef) * hvaft(j)) / dt
     279        endif ! imp_fcg
    199280        if(Turb_fcg) then
    200          do i = 1,nblvlm
    201            hThTurb_mes(i) = hThTurb_mes(i)*(hplaym(i)/1000.)**rkappa
    202          enddo
    203         endif  ! Turb_fcg
    204 
    205                PRINT*,'ht_mes ',(ht_mes(i),i=1,nblvlm)
    206                PRINT*,'hq_mes ',(hq_mes(i),i=1,nblvlm)
    207                PRINT*,'hw_mes ',(hw_mes(i),i=1,nblvlm)
    208                   if(imp_fcg) then
    209                PRINT*,'hu_mes ',(hu_mes(i),i=1,nblvlm)
    210                PRINT*,'hv_mes ',(hv_mes(i),i=1,nblvlm)
    211                   endif
    212                   if(Turb_fcg) then
    213                PRINT*,'hThTurb_mes ',(hThTurb_mes(i),i=1,nblvlm)
    214                PRINT*,'hqTurb_mes ',(hqTurb_mes(i),i=1,nblvlm)
    215                   endif
    216           IF (ts_fcg) PRINT*,'ts_subr', ts_subr
    217 !*** on interpole les champs meso_NH sur les niveaux de pression***
    218 !*** gcm . on obtient le nouveau champ after                    ***
    219             do k=1,klev
    220              if (JM(k) .eq. 0) then
    221          htaft(k)=              ht_mes(jm(k)+1)
    222          hqaft(k)=              hq_mes(jm(k)+1)
    223          hwaft(k)=              hw_mes(jm(k)+1)
    224                if(imp_fcg) then
    225            huaft(k)=              hu_mes(jm(k)+1)
    226            hvaft(k)=              hv_mes(jm(k)+1)
    227                endif ! imp_fcg
    228                if(Turb_fcg) then
    229            hThTurbaft(k)=         hThTurb_mes(jm(k)+1)
    230            hqTurbaft(k)=          hqTurb_mes(jm(k)+1)
    231                endif ! Turb_fcg
    232              else ! JM(k) .eq. 0
    233            htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1)
    234            hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1)
    235            hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1)
    236                if(imp_fcg) then
    237            huaft(k)=coef1(k)*hu_mes(jm(k))+coef2(k)*hu_mes(jm(k)+1)
    238            hvaft(k)=coef1(k)*hv_mes(jm(k))+coef2(k)*hv_mes(jm(k)+1)
    239                endif ! imp_fcg
    240                if(Turb_fcg) then
    241            hThTurbaft(k)=coef1(k)*hThTurb_mes(jm(k))                            &
    242      &               +coef2(k)*hThTurb_mes(jm(k)+1)
    243            hqTurbaft(k) =coef1(k)*hqTurb_mes(jm(k))                             &
    244      &               +coef2(k)*hqTurb_mes(jm(k)+1)
    245                endif ! Turb_fcg
    246              endif ! JM(k) .eq. 0
    247             enddo
    248             tsaft = ts_subr
    249             pasprev=pas
    250          else ! pas.gt.pasprev
    251             PRINT*,'timebef est:',timebef
    252          endif ! pas.gt.pasprev    fin du bloc relatif au passage au pas
    253                                   !de temps (meso) suivant
    254 !*** si on atteint le pas max des donnees experimentales ,on     ***
    255 !*** on conserve les derniers champs calcules                    ***
    256       if(temps.ge.pasmax)then
    257           do ll=1,klev
    258                ht(ll)=htaft(ll)
    259                hq(ll)=hqaft(ll)
    260                hw(ll)=hwaft(ll)
    261                hu(ll)=huaft(ll)
    262                hv(ll)=hvaft(ll)
    263                hThTurb(ll)=hThTurbaft(ll)
    264                hqTurb(ll)=hqTurbaft(ll)
    265           enddo
    266           ts_subr = tsaft
    267       else ! temps.ge.pasmax
    268 !*** on interpole sur les pas de temps de 10mn du gcm a partir   ***
    269 !** des pas de temps de 1h du meso_NH                            ***
    270          do j=1,klev
    271          ht(j)=((timeaft-time)*htbef(j)+(time-timebef)*htaft(j))/dt
    272          hq(j)=((timeaft-time)*hqbef(j)+(time-timebef)*hqaft(j))/dt
    273          hw(j)=((timeaft-time)*hwbef(j)+(time-timebef)*hwaft(j))/dt
    274              if(imp_fcg) then
    275          hu(j)=((timeaft-time)*hubef(j)+(time-timebef)*huaft(j))/dt
    276          hv(j)=((timeaft-time)*hvbef(j)+(time-timebef)*hvaft(j))/dt
    277              endif ! imp_fcg
    278              if(Turb_fcg) then
    279          hThTurb(j)=((timeaft-time)*hThTurbbef(j)                           &
    280      &           +(time-timebef)*hThTurbaft(j))/dt
    281          hqTurb(j)= ((timeaft-time)*hqTurbbef(j)                            &
    282      &           +(time-timebef)*hqTurbaft(j))/dt
    283              endif ! Turb_fcg
    284          enddo
    285          ts_subr = ((timeaft-time)*tsbef + (time-timebef)*tsaft)/dt
    286        endif ! temps.ge.pasmax
    287 
    288         print *,' time,timebef,timeaft',time,timebef,timeaft
    289         print *,' ht,htbef,htaft,hthturb,hthturbbef,hthturbaft'
    290         do j= 1,klev
    291            print *, j,ht(j),htbef(j),htaft(j),                              &
    292      &             hthturb(j),hthturbbef(j),hthturbaft(j)
     281          hThTurb(j) = ((timeaft - time) * hThTurbbef(j)                           &
     282                  & + (time - timebef) * hThTurbaft(j)) / dt
     283          hqTurb(j) = ((timeaft - time) * hqTurbbef(j)                            &
     284                  & + (time - timebef) * hqTurbaft(j)) / dt
     285        endif ! Turb_fcg
     286      enddo
     287      ts_subr = ((timeaft - time) * tsbef + (time - timebef) * tsaft) / dt
     288    endif ! temps.ge.pasmax
     289
     290    print *, ' time,timebef,timeaft', time, timebef, timeaft
     291    print *, ' ht,htbef,htaft,hthturb,hthturbbef,hthturbaft'
     292    do j = 1, klev
     293      print *, j, ht(j), htbef(j), htaft(j), &
     294              &             hthturb(j), hthturbbef(j), hthturbaft(j)
     295    enddo
     296    print *, ' hq,hqbef,hqaft,hqturb,hqturbbef,hqturbaft'
     297    do j = 1, klev
     298      print *, j, hq(j), hqbef(j), hqaft(j), &
     299              &             hqturb(j), hqturbbef(j), hqturbaft(j)
     300    enddo
     301
     302    !-------------------------------------------------------------------
     303
     304    IF (Ts_fcg) Ts = Ts_subr
     305    return
     306
     307    !-----------------------------------------------------------------------
     308    ! on sort les champs de "convergence" pour l instant initial 'in'
     309    ! ceci se passe au pas temps itap=0 de la physique
     310    !-----------------------------------------------------------------------
     311    entry get_uvd2(itap, dtime, file_forctl, file_fordat, &
     312            &           ht, hq, hw, hu, hv, hThTurb, hqTurb, ts, &
     313            &           imp_fcg, ts_fcg, Tp_fcg, Turb_fcg)
     314    PRINT*, 'le pas itap est:', itap
     315
     316    !===================================================================
     317
     318    write(*, '(a)') 'OPEN ' // file_forctl
     319    open(97, FILE = file_forctl, FORM = 'FORMATTED')
     320
     321    !------------------
     322    do i = 1, 1000
     323      read(97, 1000, end = 999) string
     324      1000 format (a4)
     325      if (string == 'TDEF') go to 50
     326    enddo
     327    50   backspace(97)
     328    !-------------------------------------------------------------------
     329    !   *** on lit le pas de temps dans le fichier de donnees ***
     330    !   *** "forcing.ctl" et pasmax                           ***
     331    !-------------------------------------------------------------------
     332    read(97, 2000) aaa
     333    2000  format (a80)
     334    PRINT*, 'aaa est', aaa
     335    aaa = spaces(aaa, 1)
     336    PRINT*, 'aaa', aaa
     337    CALL getsch(aaa, ' ', ' ', 5, atemps, nch)
     338    PRINT*, 'atemps est', atemps
     339    atemps = atemps(1:nch - 2)
     340    PRINT*, 'atemps', atemps
     341    read(atemps, *) imn
     342    dt = imn * 60
     343    PRINT*, 'le pas de temps dt', dt
     344    CALL getsch(aaa, ' ', ' ', 2, apasmax, nch)
     345    apasmax = apasmax(1:nch)
     346    read(apasmax, *) ipa
     347    pasmax = ipa
     348    PRINT*, 'pasmax est', pasmax
     349    CLOSE(97)
     350    !------------------------------------------------------------------
     351    ! *** on lit le pas de temps initial de la simulation ***
     352    !------------------------------------------------------------------
     353    in = itap
     354    !c                  pasprev=in
     355    !c                  time0=dt*(pasprev-1)
     356    pasprev = in - 1
     357    time0 = dt * pasprev
     358
     359    close(98)
     360
     361    write(*, '(a)') 'OPEN ' // file_fordat
     362    open(99, FILE = file_fordat, FORM = 'UNFORMATTED', ACCESS = 'DIRECT', RECL = 8)
     363    icomp1 = nblvlm * 4
     364    IF (ts_fcg) icomp1 = icomp1 + 1
     365    IF (imp_fcg) icomp1 = icomp1 + nblvlm * 2
     366    IF (Turb_fcg) icomp1 = icomp1 + nblvlm * 2
     367    icompt = icomp1 * (in - 1)
     368    CALL rdgrads(99, icompt, nblvlm, z, ht_mes, hq_mes, hw_mes              &
     369            &, hu_mes, hv_mes, hthturb_mes, hqturb_mes              &
     370            &, ts_fcg, ts_subr, imp_fcg, Turb_fcg)
     371    print *, 'get_uvd : rdgrads ->'
     372    print *, tp_fcg
     373
     374    ! following commented out because we have temperature already in ARM case
     375    !   (otherwise this is the potential temperature )
     376    !------------------------------------------------------------------------
     377    if(Tp_fcg) then
     378      do i = 1, nblvlm
     379        ht_mes(i) = ht_mes(i) * (hplaym(i) / 1000.)**rkappa
     380      enddo
     381    endif ! Tp_fcg
     382    PRINT*, 'ht_mes ', (ht_mes(i), i = 1, nblvlm)
     383    PRINT*, 'hq_mes ', (hq_mes(i), i = 1, nblvlm)
     384    PRINT*, 'hw_mes ', (hw_mes(i), i = 1, nblvlm)
     385    if(imp_fcg) then
     386      PRINT*, 'hu_mes ', (hu_mes(i), i = 1, nblvlm)
     387      PRINT*, 'hv_mes ', (hv_mes(i), i = 1, nblvlm)
     388      PRINT*, 't', ts_subr
     389    endif ! imp_fcg
     390    if(Turb_fcg) then
     391      PRINT*, 'hThTurb_mes ', (hThTurb_mes(i), i = 1, nblvlm)
     392      PRINT*, 'hqTurb ', (hqTurb_mes(i), i = 1, nblvlm)
     393    endif ! Turb_fcg
     394    !----------------------------------------------------------------------
     395    ! on a obtenu des champs initiaux sur les niveaux du meso_NH
     396    ! on interpole sur les niveaux du gcm(niveau pression bien sur!)
     397    !-----------------------------------------------------------------------
     398    do k = 1, klev
     399      if (JM(k) == 0) then
     400        !FKC bug? ne faut il pas convertir tsol en tendance ????
     401        !RT bug taken care of by removing the stuff
     402        htaft(k) = ht_mes(jm(k) + 1)
     403        hqaft(k) = hq_mes(jm(k) + 1)
     404        hwaft(k) = hw_mes(jm(k) + 1)
     405        if(imp_fcg) then
     406          huaft(k) = hu_mes(jm(k) + 1)
     407          hvaft(k) = hv_mes(jm(k) + 1)
     408        endif ! imp_fcg
     409        if(Turb_fcg) then
     410          hThTurbaft(k) = hThTurb_mes(jm(k) + 1)
     411          hqTurbaft(k) = hqTurb_mes(jm(k) + 1)
     412        endif ! Turb_fcg
     413      else ! JM(k) .eq. 0
     414        htaft(k) = coef1(k) * ht_mes(jm(k)) + coef2(k) * ht_mes(jm(k) + 1)
     415        hqaft(k) = coef1(k) * hq_mes(jm(k)) + coef2(k) * hq_mes(jm(k) + 1)
     416        hwaft(k) = coef1(k) * hw_mes(jm(k)) + coef2(k) * hw_mes(jm(k) + 1)
     417        if(imp_fcg) then
     418          huaft(k) = coef1(k) * hu_mes(jm(k)) + coef2(k) * hu_mes(jm(k) + 1)
     419          hvaft(k) = coef1(k) * hv_mes(jm(k)) + coef2(k) * hv_mes(jm(k) + 1)
     420        endif ! imp_fcg
     421        if(Turb_fcg) then
     422          hThTurbaft(k) = coef1(k) * hThTurb_mes(jm(k))                        &
     423                  & + coef2(k) * hThTurb_mes(jm(k) + 1)
     424          hqTurbaft(k) = coef1(k) * hqTurb_mes(jm(k))                         &
     425                  & + coef2(k) * hqTurb_mes(jm(k) + 1)
     426        endif ! Turb_fcg
     427      endif ! JM(k) .eq. 0
     428    enddo
     429    tsaft = ts_subr
     430    ! valeurs initiales des champs de convergence
     431    do k = 1, klev
     432      ht(k) = htaft(k)
     433      hq(k) = hqaft(k)
     434      hw(k) = hwaft(k)
     435      if(imp_fcg) then
     436        hu(k) = huaft(k)
     437        hv(k) = hvaft(k)
     438      endif ! imp_fcg
     439      if(Turb_fcg) then
     440        hThTurb(k) = hThTurbaft(k)
     441        hqTurb(k) = hqTurbaft(k)
     442      endif ! Turb_fcg
     443    enddo
     444    ts_subr = tsaft
     445    close(99)
     446    close(98)
     447
     448    !-------------------------------------------------------------------
     449
     450    IF (Ts_fcg) Ts = Ts_subr
     451    return
     452
     453    999     continue
     454    stop 'erreur lecture, file forcing.ctl'
     455  end
     456
     457  SUBROUTINE advect_tvl(dtime, zt, zq, vu_f, vv_f, t_f, q_f                   &
     458          &, d_t_adv, d_q_adv)
     459    use dimphy
     460    implicit none
     461
     462    INCLUDE "dimensions.h"
     463    !cccc      INCLUDE "dimphy.h"
     464
     465    integer k
     466    real dtime, fact, du, dv, cx, cy, alx, aly
     467    real zt(klev), zq(klev, 3)
     468    real vu_f(klev), vv_f(klev), t_f(klev), q_f(klev, 3)
     469
     470    real d_t_adv(klev), d_q_adv(klev, 3)
     471
     472    ! Velocity of moving cell
     473    data cx, cy /12., -2./
     474
     475    ! Dimensions of moving cell
     476    data alx, aly /100000., 150000./
     477
     478    do k = 1, klev
     479      du = abs(vu_f(k) - cx) / alx
     480      dv = abs(vv_f(k) - cy) / aly
     481      fact = dtime * (du + dv - du * dv * dtime)
     482      d_t_adv(k) = fact * (t_f(k) - zt(k))
     483      d_q_adv(k, 1) = fact * (q_f(k, 1) - zq(k, 1))
     484      d_q_adv(k, 2) = fact * (q_f(k, 2) - zq(k, 2))
     485      d_q_adv(k, 3) = fact * (q_f(k, 3) - zq(k, 3))
     486    enddo
     487
     488    return
     489  end
     490
     491  SUBROUTINE copie(klevgcm, playgcm, psolgcm, file_forctl)
     492    implicit none
     493
     494    !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     495    ! cette routine remplit les COMMON com1_phys_gcss et com2_phys_gcss.h
     496    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     497
     498    INTEGER klev !nombre de niveau de pression du GCM
     499    REAL play(100)  !pression en Pa au milieu de chaque couche GCM
     500    INTEGER JM(100)
     501    REAL coef1(100)   !coefficient d interpolation
     502    REAL coef2(100)   !coefficient d interpolation
     503
     504    INTEGER nblvlm !nombre de niveau de pression du mesoNH
     505    REAL playm(100) !pression en Pa au milieu de chaque couche Meso-NH
     506    REAL hplaym(100)!pression en hecto-Pa des milieux de couche Meso-NH
     507
     508    COMMON/com1_phys_gcss/play, coef1, coef2, JM, klev
     509    COMMON/com2_phys_gcss/playm, hplaym, nblvlm
     510
     511    integer k, klevgcm
     512    real playgcm(klevgcm) ! pression en milieu de couche du gcm
     513    real psolgcm
     514    character*80 file_forctl
     515
     516    klev = klevgcm
     517
     518    !---------------------------------------------------------------------
     519    ! pression au milieu des couches du gcm dans la physiq
     520    ! (SB: remplace le CALL conv_lipress_gcm(playgcm) )
     521    !---------------------------------------------------------------------
     522
     523    do k = 1, klev
     524      play(k) = playgcm(k)
     525      PRINT*, 'la pression gcm est:', play(k)
     526    enddo
     527
     528    !----------------------------------------------------------------------
     529    ! lecture du descripteur des donnees Meso-NH (forcing.ctl):
     530    !  -> nb niveaux du meso.NH (nblvlm) + pressions meso.NH
     531    ! (on remplit le COMMON com2_phys_gcss)
     532    !----------------------------------------------------------------------
     533
     534    CALL mesolupbis(file_forctl)
     535
     536    PRINT*, 'la valeur de nblvlm est:', nblvlm
     537
     538    !----------------------------------------------------------------------
     539    ! etude de la correspondance entre les niveaux meso.NH et GCM;
     540    ! calcul des coefficients d interpolation coef1 et coef2
     541    ! (on remplit le COMMON com1_phys_gcss)
     542    !----------------------------------------------------------------------
     543
     544    CALL corresbis(psolgcm)
     545
     546    !---------------------------------------------------------
     547    ! TEST sur le remplissage de com1_phys_gcss et com2_phys_gcss:
     548    !---------------------------------------------------------
     549
     550    write(*, *) ' '
     551    write(*, *) 'TESTS com1_phys_gcss et com2_phys_gcss dans copie.F'
     552    write(*, *) '--------------------------------------'
     553    write(*, *) 'GCM: nb niveaux:', klev, ' et pression, coeffs:'
     554    do k = 1, klev
     555      write(*, *) play(k), coef1(k), coef2(k)
     556    enddo
     557    write(*, *) 'MESO-NH: nb niveaux:', nblvlm, ' et pression:'
     558    do k = 1, nblvlm
     559      write(*, *) playm(k), hplaym(k)
     560    enddo
     561    write(*, *) ' '
     562
     563  end
     564  SUBROUTINE mesolupbis(file_forctl)
     565    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     566
     567    ! Lecture descripteur des donnees MESO-NH (forcing.ctl):
     568    ! -------------------------------------------------------
     569
     570    !     Cette subroutine lit dans le fichier de controle "essai.ctl"
     571    !     et affiche le nombre de niveaux du Meso-NH ainsi que les valeurs
     572    !     des pressions en milieu de couche du Meso-NH (en Pa puis en hPa).
     573    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     574
     575    INTEGER nblvlm !nombre de niveau de pression du mesoNH
     576    REAL playm(100)  !pression en Pa milieu de chaque couche Meso-NH
     577    REAL hplaym(100) !pression en hPa des milieux de couche Meso-NH
     578    COMMON/com2_phys_gcss/playm, hplaym, nblvlm
     579
     580    INTEGER i, lu, mlz, mlzh
     581
     582    character*80 file_forctl
     583
     584    character*4 a
     585    character*80 aaa, anblvl, spaces
     586    integer nch
     587
     588    lu = 9
     589    open(lu, file = file_forctl, form = 'formatted')
     590
     591    do i = 1, 1000
     592      read(lu, 1000, end = 999) a
     593      if (a == 'ZDEF') go to 100
     594    enddo
     595
     596    100  backspace(lu)
     597    PRINT*, '  DESCRIPTION DES 2 MODELES : '
     598    PRINT*, ' '
     599
     600    read(lu, 2000) aaa
     601    2000  format (a80)
     602    aaa = spaces(aaa, 1)
     603    CALL getsch(aaa, ' ', ' ', 2, anblvl, nch)
     604    read(anblvl, *) nblvlm
     605
     606    PRINT*, 'nbre de niveaux de pression Meso-NH :', nblvlm
     607    PRINT*, ' '
     608    PRINT*, 'pression en Pa de chaque couche du meso-NH :'
     609
     610    read(lu, *) (playm(mlz), mlz = 1, nblvlm)
     611    !      Si la pression est en HPa, la multiplier par 100
     612    if (playm(1) < 10000.) then
     613      do mlz = 1, nblvlm
     614        playm(mlz) = playm(mlz) * 100.
     615      enddo
     616    endif
     617    PRINT*, (playm(mlz), mlz = 1, nblvlm)
     618
     619    1000 format (a4)
     620
     621    PRINT*, ' '
     622    do mlzh = 1, nblvlm
     623      hplaym(mlzh) = playm(mlzh) / 100.
     624    enddo
     625
     626    PRINT*, 'pression en hPa de chaque couche du meso-NH: '
     627    PRINT*, (hplaym(mlzh), mlzh = 1, nblvlm)
     628
     629    close (lu)
     630    return
     631
     632    999  stop 'erreur lecture des niveaux pression des donnees'
     633  end
     634
     635  SUBROUTINE rdgrads(itape, icount, nl, z, ht, hq, hw, hu, hv, hthtur, hqtur, &
     636          &  ts_fcg, ts, imp_fcg, Turb_fcg)
     637    IMPLICIT none
     638    INTEGER itape, icount, icomp, nl
     639    real z(nl), ht(nl), hq(nl), hw(nl), hu(nl), hv(nl)
     640    real hthtur(nl), hqtur(nl)
     641    real ts
     642
     643    INTEGER k
     644
     645    LOGICAL imp_fcg, ts_fcg, Turb_fcg
     646
     647    icomp = icount
     648
     649    do k = 1, nl
     650      icomp = icomp + 1
     651      read(itape, rec = icomp)z(k)
     652      print *, 'icomp,k,z(k) ', icomp, k, z(k)
     653    enddo
     654    do k = 1, nl
     655      icomp = icomp + 1
     656      read(itape, rec = icomp)hT(k)
     657      PRINT*, hT(k), k
     658    enddo
     659    do k = 1, nl
     660      icomp = icomp + 1
     661      read(itape, rec = icomp)hQ(k)
     662    enddo
     663
     664    if(turb_fcg) then
     665      do k = 1, nl
     666        icomp = icomp + 1
     667        read(itape, rec = icomp)hThTur(k)
     668      enddo
     669      do k = 1, nl
     670        icomp = icomp + 1
     671        read(itape, rec = icomp)hqTur(k)
     672      enddo
     673    endif
     674    print *, ' apres lecture hthtur, hqtur'
     675
     676    if(imp_fcg) then
     677
     678      do k = 1, nl
     679        icomp = icomp + 1
     680        read(itape, rec = icomp)hu(k)
     681      enddo
     682      do k = 1, nl
     683        icomp = icomp + 1
     684        read(itape, rec = icomp)hv(k)
     685      enddo
     686
     687    endif
     688
     689    do k = 1, nl
     690      icomp = icomp + 1
     691      read(itape, rec = icomp)hw(k)
     692    enddo
     693
     694    if(ts_fcg) then
     695      icomp = icomp + 1
     696      read(itape, rec = icomp)ts
     697    endif
     698
     699    print *, ' rdgrads ->'
     700
     701    RETURN
     702  END
     703
     704  SUBROUTINE corresbis(psol)
     705    implicit none
     706
     707    !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     708    ! Cette subroutine calcule et affiche les valeurs des coefficients
     709    ! d interpolation qui serviront dans la formule d interpolation elle-
     710    ! meme.
     711    !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     712
     713    INTEGER klev    !nombre de niveau de pression du GCM
     714    REAL play(100)  !pression en Pa au milieu de chaque couche GCM
     715    INTEGER JM(100)
     716    REAL coef1(100) !coefficient d interpolation
     717    REAL coef2(100) !coefficient d interpolation
     718
     719    INTEGER nblvlm !nombre de niveau de pression du mesoNH
     720    REAL playm(100) !pression en Pa milieu de chaque couche Meso-NH
     721    REAL hplaym(100)!pression en hPa des milieux de couche Meso-NH
     722
     723    COMMON/com1_phys_gcss/play, coef1, coef2, JM, klev
     724    COMMON/com2_phys_gcss/playm, hplaym, nblvlm
     725
     726    REAL psol
     727    REAL val
     728    INTEGER k, mlz
     729
     730    do k = 1, klev
     731      val = play(k)
     732      if (val > playm(1)) then
     733        mlz = 0
     734        JM(1) = mlz
     735        coef1(1) = (playm(mlz + 1) - val) / (playm(mlz + 1) - psol)
     736        coef2(1) = (val - psol) / (playm(mlz + 1) - psol)
     737      else if (val > playm(nblvlm)) then
     738        do mlz = 1, nblvlm
     739          if (val <= playm(mlz).and. val > playm(mlz + 1))then
     740            JM(k) = mlz
     741            coef1(k) = (playm(mlz + 1) - val) / (playm(mlz + 1) - playm(mlz))
     742            coef2(k) = (val - playm(mlz)) / (playm(mlz + 1) - playm(mlz))
     743          endif
    293744        enddo
    294         print *,' hq,hqbef,hqaft,hqturb,hqturbbef,hqturbaft'
    295         do j= 1,klev
    296            print *, j,hq(j),hqbef(j),hqaft(j),                              &
    297      &             hqturb(j),hqturbbef(j),hqturbaft(j)
    298         enddo
    299 
    300 !-------------------------------------------------------------------
    301 
    302          IF (Ts_fcg) Ts = Ts_subr
    303          return
    304 
    305 !-----------------------------------------------------------------------
    306 ! on sort les champs de "convergence" pour l instant initial 'in'
    307 ! ceci se passe au pas temps itap=0 de la physique
    308 !-----------------------------------------------------------------------
    309         entry get_uvd2(itap,dtime,file_forctl,file_fordat,                  &
    310      &           ht,hq,hw,hu,hv,hThTurb,hqTurb,ts,                          &
    311      &           imp_fcg,ts_fcg,Tp_fcg,Turb_fcg)
    312              PRINT*,'le pas itap est:',itap
    313 
    314 !===================================================================
    315 
    316        write(*,'(a)') 'OPEN '//file_forctl
    317        open(97,FILE=file_forctl,FORM='FORMATTED')
    318 
    319 !------------------
    320       do i=1,1000
    321       read(97,1000,end=999) string
    322  1000 format (a4)
    323       if (string .eq. 'TDEF') go to 50
    324       enddo
    325  50   backspace(97)
    326 !-------------------------------------------------------------------
    327 !   *** on lit le pas de temps dans le fichier de donnees ***
    328 !   *** "forcing.ctl" et pasmax                           ***
    329 !-------------------------------------------------------------------
    330       read(97,2000) aaa
    331  2000  format (a80)
    332          PRINT*,'aaa est',aaa
    333       aaa=spaces(aaa,1)
    334          PRINT*,'aaa',aaa
    335       CALL getsch(aaa,' ',' ',5,atemps,nch)
    336          PRINT*,'atemps est',atemps
    337         atemps=atemps(1:nch-2)
    338          PRINT*,'atemps',atemps
    339         read(atemps,*) imn
    340         dt=imn*60
    341          PRINT*,'le pas de temps dt',dt
    342       CALL getsch(aaa,' ',' ',2,apasmax,nch)
    343         apasmax=apasmax(1:nch)
    344         read(apasmax,*) ipa
    345         pasmax=ipa
    346          PRINT*,'pasmax est',pasmax
    347       CLOSE(97)
    348 !------------------------------------------------------------------
    349 ! *** on lit le pas de temps initial de la simulation ***
    350 !------------------------------------------------------------------
    351                   in=itap
    352 !c                  pasprev=in
    353 !c                  time0=dt*(pasprev-1)
    354                   pasprev=in-1
    355                   time0=dt*pasprev
    356 
    357           close(98)
    358 
    359       write(*,'(a)') 'OPEN '//file_fordat
    360       open(99,FILE=file_fordat,FORM='UNFORMATTED',                          &
    361      &          ACCESS='DIRECT',RECL=8)
    362           icomp1 = nblvlm*4
    363           IF (ts_fcg) icomp1 = icomp1 + 1
    364           IF (imp_fcg) icomp1 = icomp1 + nblvlm*2
    365           IF (Turb_fcg) icomp1 = icomp1 + nblvlm*2
    366           icompt = icomp1*(in-1)
    367           CALL rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes              &
    368      &                   ,hu_mes,hv_mes,hthturb_mes,hqturb_mes              &
    369      &                   ,ts_fcg,ts_subr,imp_fcg,Turb_fcg)
    370           print *, 'get_uvd : rdgrads ->'
    371           print *, tp_fcg
    372 
    373 ! following commented out because we have temperature already in ARM case
    374 !   (otherwise this is the potential temperature )
    375 !------------------------------------------------------------------------
    376                if(Tp_fcg) then
    377           do i = 1,nblvlm
    378             ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa
    379           enddo
    380                endif ! Tp_fcg
    381            PRINT*,'ht_mes ',(ht_mes(i),i=1,nblvlm)
    382            PRINT*,'hq_mes ',(hq_mes(i),i=1,nblvlm)
    383            PRINT*,'hw_mes ',(hw_mes(i),i=1,nblvlm)
    384               if(imp_fcg) then
    385            PRINT*,'hu_mes ',(hu_mes(i),i=1,nblvlm)
    386            PRINT*,'hv_mes ',(hv_mes(i),i=1,nblvlm)
    387            PRINT*,'t',ts_subr
    388               endif ! imp_fcg
    389               if(Turb_fcg) then
    390                  PRINT*,'hThTurb_mes ',(hThTurb_mes(i),i=1,nblvlm)
    391                  PRINT*,'hqTurb ',     (hqTurb_mes(i),i=1,nblvlm)
    392               endif ! Turb_fcg
    393 !----------------------------------------------------------------------
    394 ! on a obtenu des champs initiaux sur les niveaux du meso_NH
    395 ! on interpole sur les niveaux du gcm(niveau pression bien sur!)
    396 !-----------------------------------------------------------------------
    397             do k=1,klev
    398              if (JM(k) .eq. 0) then
    399 !FKC bug? ne faut il pas convertir tsol en tendance ????
    400 !RT bug taken care of by removing the stuff
    401            htaft(k)=              ht_mes(jm(k)+1)
    402            hqaft(k)=              hq_mes(jm(k)+1)
    403            hwaft(k)=              hw_mes(jm(k)+1)
    404                if(imp_fcg) then
    405            huaft(k)=              hu_mes(jm(k)+1)
    406            hvaft(k)=              hv_mes(jm(k)+1)
    407                endif ! imp_fcg
    408                if(Turb_fcg) then
    409            hThTurbaft(k)=         hThTurb_mes(jm(k)+1)
    410            hqTurbaft(k)=          hqTurb_mes(jm(k)+1)
    411                endif ! Turb_fcg
    412              else ! JM(k) .eq. 0
    413            htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1)
    414            hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1)
    415            hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1)
    416                if(imp_fcg) then
    417            huaft(k)=coef1(k)*hu_mes(jm(k))+coef2(k)*hu_mes(jm(k)+1)
    418            hvaft(k)=coef1(k)*hv_mes(jm(k))+coef2(k)*hv_mes(jm(k)+1)
    419                endif ! imp_fcg
    420                if(Turb_fcg) then
    421            hThTurbaft(k)=coef1(k)*hThTurb_mes(jm(k))                        &
    422      &                  +coef2(k)*hThTurb_mes(jm(k)+1)
    423            hqTurbaft(k) =coef1(k)*hqTurb_mes(jm(k))                         &
    424      &                  +coef2(k)*hqTurb_mes(jm(k)+1)
    425                endif ! Turb_fcg
    426              endif ! JM(k) .eq. 0
    427             enddo
    428             tsaft = ts_subr
    429 ! valeurs initiales des champs de convergence
    430           do k=1,klev
    431              ht(k)=htaft(k)
    432              hq(k)=hqaft(k)
    433              hw(k)=hwaft(k)
    434                 if(imp_fcg) then
    435              hu(k)=huaft(k)
    436              hv(k)=hvaft(k)
    437                 endif ! imp_fcg
    438                 if(Turb_fcg) then
    439              hThTurb(k)=hThTurbaft(k)
    440              hqTurb(k) =hqTurbaft(k)
    441                 endif ! Turb_fcg
    442           enddo
    443           ts_subr = tsaft
    444           close(99)
    445           close(98)
    446 
    447 !-------------------------------------------------------------------
    448 
    449 
    450  100      IF (Ts_fcg) Ts = Ts_subr
    451         return
    452 
    453 999     continue
    454         stop 'erreur lecture, file forcing.ctl'
    455         end
    456 
    457       SUBROUTINE advect_tvl(dtime,zt,zq,vu_f,vv_f,t_f,q_f                   &
    458      &                     ,d_t_adv,d_q_adv)
    459       use dimphy
    460       implicit none
    461 
    462       INCLUDE "dimensions.h"
    463 !cccc      INCLUDE "dimphy.h"
    464 
    465       integer k
    466       real dtime, fact, du, dv, cx, cy, alx, aly
    467       real zt(klev), zq(klev,3)
    468       real vu_f(klev), vv_f(klev), t_f(klev), q_f(klev,3)
    469 
    470       real d_t_adv(klev), d_q_adv(klev,3)
    471 
    472 ! Velocity of moving cell
    473       data cx,cy /12., -2./
    474 
    475 ! Dimensions of moving cell
    476       data alx,aly /100000.,150000./
    477 
    478       do k = 1, klev
    479             du = abs(vu_f(k)-cx)/alx
    480             dv = abs(vv_f(k)-cy)/aly
    481             fact = dtime *(du+dv-du*dv*dtime)
    482             d_t_adv(k) = fact * (t_f(k)-zt(k))
    483             d_q_adv(k,1) = fact * (q_f(k,1)-zq(k,1))
    484             d_q_adv(k,2) = fact * (q_f(k,2)-zq(k,2))
    485             d_q_adv(k,3) = fact * (q_f(k,3)-zq(k,3))
    486       enddo
    487 
    488       return
    489       end
    490 
    491       SUBROUTINE copie(klevgcm,playgcm,psolgcm,file_forctl)
    492       implicit none
    493 
    494 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    495 ! cette routine remplit les COMMON com1_phys_gcss et com2_phys_gcss.h
    496 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    497 
    498       INTEGER klev !nombre de niveau de pression du GCM
    499       REAL play(100)  !pression en Pa au milieu de chaque couche GCM
    500       INTEGER JM(100)
    501       REAL coef1(100)   !coefficient d interpolation
    502       REAL coef2(100)   !coefficient d interpolation
    503 
    504       INTEGER nblvlm !nombre de niveau de pression du mesoNH
    505       REAL playm(100) !pression en Pa au milieu de chaque couche Meso-NH
    506       REAL hplaym(100)!pression en hecto-Pa des milieux de couche Meso-NH
    507 
    508       COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
    509       COMMON/com2_phys_gcss/playm,hplaym,nblvlm
    510 
    511       integer k,klevgcm
    512       real playgcm(klevgcm) ! pression en milieu de couche du gcm
    513       real psolgcm
    514       character*80 file_forctl
    515 
    516       klev = klevgcm
    517 
    518 !---------------------------------------------------------------------
    519 ! pression au milieu des couches du gcm dans la physiq
    520 ! (SB: remplace le CALL conv_lipress_gcm(playgcm) )
    521 !---------------------------------------------------------------------
    522 
    523        do k = 1, klev
    524         play(k) = playgcm(k)
    525         PRINT*,'la pression gcm est:',play(k)
    526        enddo
    527 
    528 !----------------------------------------------------------------------
    529 ! lecture du descripteur des donnees Meso-NH (forcing.ctl):
    530 !  -> nb niveaux du meso.NH (nblvlm) + pressions meso.NH
    531 ! (on remplit le COMMON com2_phys_gcss)
    532 !----------------------------------------------------------------------
    533 
    534       CALL mesolupbis(file_forctl)
    535 
    536       PRINT*,'la valeur de nblvlm est:',nblvlm
    537 
    538 !----------------------------------------------------------------------
    539 ! etude de la correspondance entre les niveaux meso.NH et GCM;
    540 ! calcul des coefficients d interpolation coef1 et coef2
    541 ! (on remplit le COMMON com1_phys_gcss)
    542 !----------------------------------------------------------------------
    543 
    544       CALL corresbis(psolgcm)
    545 
    546 !---------------------------------------------------------
    547 ! TEST sur le remplissage de com1_phys_gcss et com2_phys_gcss:
    548 !---------------------------------------------------------
    549  
    550       write(*,*) ' '
    551       write(*,*) 'TESTS com1_phys_gcss et com2_phys_gcss dans copie.F'
    552       write(*,*) '--------------------------------------'
    553       write(*,*) 'GCM: nb niveaux:',klev,' et pression, coeffs:'
    554       do k = 1, klev
    555       write(*,*) play(k), coef1(k), coef2(k)
    556       enddo
    557       write(*,*) 'MESO-NH: nb niveaux:',nblvlm,' et pression:'
    558       do k = 1, nblvlm
    559       write(*,*) playm(k), hplaym(k)
    560       enddo
    561       write(*,*) ' '
    562 
    563       end
    564       SUBROUTINE mesolupbis(file_forctl)
    565       implicit none
    566 
    567 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    568 
    569 ! Lecture descripteur des donnees MESO-NH (forcing.ctl):
    570 ! -------------------------------------------------------
    571 
    572 !     Cette subroutine lit dans le fichier de controle "essai.ctl"
    573 !     et affiche le nombre de niveaux du Meso-NH ainsi que les valeurs
    574 !     des pressions en milieu de couche du Meso-NH (en Pa puis en hPa).
    575 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    576 
    577       INTEGER nblvlm !nombre de niveau de pression du mesoNH
    578       REAL playm(100)  !pression en Pa milieu de chaque couche Meso-NH
    579       REAL hplaym(100) !pression en hPa des milieux de couche Meso-NH
    580       COMMON/com2_phys_gcss/playm,hplaym,nblvlm
    581 
    582       INTEGER i,lu,mlz,mlzh
    583  
    584       character*80 file_forctl
    585 
    586       character*4 a
    587       character*80 aaa,anblvl,spaces
    588       integer nch
    589 
    590       lu=9
    591       open(lu,file=file_forctl,form='formatted')
    592 
    593       do i=1,1000
    594       read(lu,1000,end=999) a
    595       if (a .eq. 'ZDEF') go to 100
    596       enddo
    597 
    598  100  backspace(lu)
    599       PRINT*,'  DESCRIPTION DES 2 MODELES : '
    600       PRINT*,' '
    601 
    602       read(lu,2000) aaa
    603  2000  format (a80)
    604        aaa=spaces(aaa,1)
    605        CALL getsch(aaa,' ',' ',2,anblvl,nch)
    606          read(anblvl,*) nblvlm
    607 
    608       PRINT*,'nbre de niveaux de pression Meso-NH :',nblvlm
    609       PRINT*,' '
    610       PRINT*,'pression en Pa de chaque couche du meso-NH :'
    611 
    612       read(lu,*) (playm(mlz),mlz=1,nblvlm)
    613 !      Si la pression est en HPa, la multiplier par 100
    614       if (playm(1) .lt. 10000.) then
    615         do mlz = 1,nblvlm
    616          playm(mlz) = playm(mlz)*100.
    617         enddo
     745      else
     746        JM(k) = nblvlm - 1
     747        coef1(k) = 0.
     748        coef2(k) = 0.
    618749      endif
    619       PRINT*,(playm(mlz),mlz=1,nblvlm)
    620 
    621  1000 format (a4)
    622  1001 format(5x,i2)
    623 
    624       PRINT*,' '
    625       do mlzh=1,nblvlm
    626       hplaym(mlzh)=playm(mlzh)/100.
    627       enddo
    628 
    629       PRINT*,'pression en hPa de chaque couche du meso-NH: '
    630       PRINT*,(hplaym(mlzh),mlzh=1,nblvlm)
    631 
    632       close (lu)
    633       return
    634 
    635  999  stop 'erreur lecture des niveaux pression des donnees'
    636       end
    637 
    638       SUBROUTINE rdgrads(itape,icount,nl,z,ht,hq,hw,hu,hv,hthtur,hqtur,     &
    639      &  ts_fcg,ts,imp_fcg,Turb_fcg)
    640       IMPLICIT none
    641       INTEGER itape,icount,icomp, nl
    642       real z(nl),ht(nl),hq(nl),hw(nl),hu(nl),hv(nl)
    643       real hthtur(nl),hqtur(nl)
    644       real ts
    645 
    646       INTEGER k
    647 
    648       LOGICAL imp_fcg,ts_fcg,Turb_fcg
    649 
    650       icomp = icount
    651 
    652 
    653          do k=1,nl
    654             icomp=icomp+1
    655             read(itape,rec=icomp)z(k)
    656             print *,'icomp,k,z(k) ',icomp,k,z(k)
    657          enddo
    658          do k=1,nl
    659             icomp=icomp+1
    660             read(itape,rec=icomp)hT(k)
    661              PRINT*, hT(k), k
    662          enddo
    663          do k=1,nl
    664             icomp=icomp+1
    665             read(itape,rec=icomp)hQ(k)
    666          enddo
    667 
    668              if(turb_fcg) then
    669          do k=1,nl
    670             icomp=icomp+1
    671            read(itape,rec=icomp)hThTur(k)
    672          enddo
    673          do k=1,nl
    674             icomp=icomp+1
    675            read(itape,rec=icomp)hqTur(k)
    676          enddo
    677              endif
    678          print *,' apres lecture hthtur, hqtur'
    679 
    680           if(imp_fcg) then
    681 
    682          do k=1,nl
    683             icomp=icomp+1
    684            read(itape,rec=icomp)hu(k)
    685          enddo
    686          do k=1,nl
    687             icomp=icomp+1
    688             read(itape,rec=icomp)hv(k)
    689          enddo
    690 
    691           endif
    692 
    693          do k=1,nl
    694             icomp=icomp+1
    695             read(itape,rec=icomp)hw(k)
    696          enddo
    697 
    698               if(ts_fcg) then
    699          icomp=icomp+1
    700          read(itape,rec=icomp)ts
    701               endif
    702 
    703       print *,' rdgrads ->'
    704 
     750    enddo
     751
     752    !c      if (play(klev) .le. playm(nblvlm)) then
     753    !c         mlz=nblvlm-1
     754    !c         JM(klev)=mlz
     755    !c         coef1(klev)=(playm(mlz+1)-val)
     756    !c     *            /(playm(mlz+1)-playm(mlz))
     757    !c         coef2(klev)=(val-playm(mlz))
     758    !c     *            /(playm(mlz+1)-playm(mlz))
     759    !c      endif
     760
     761    PRINT*, ' '
     762    PRINT*, '         INTERPOLATION  : '
     763    PRINT*, ' '
     764    PRINT*, 'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
     765    PRINT*, (JM(k), k = 1, klev)
     766    PRINT*, 'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
     767    PRINT*, (JM(k), k = 1, klev)
     768    PRINT*, ' '
     769    PRINT*, 'vals du premier coef d"interpolation pour les 9 niveaux: '
     770    PRINT*, (coef1(k), k = 1, klev)
     771    PRINT*, ' '
     772    PRINT*, 'valeurs du deuxieme coef d"interpolation pour les 9 niveaux:'
     773    PRINT*, (coef2(k), k = 1, klev)
     774
     775    return
     776  end
     777  SUBROUTINE GETSCH(STR, DEL, TRM, NTH, SST, NCH)
     778    !***************************************************************
     779    !*                                                             *
     780    !*                                                             *
     781    !* GETSCH                                                      *
     782    !*                                                             *
     783    !*                                                             *
     784    !* modified by :                                               *
     785    !***************************************************************
     786    !*   Return in SST the character string found between the NTH-1 and NTH
     787    !*   occurence of the delimiter 'DEL' but before the terminator 'TRM' in
     788    !*   the input string 'STR'. If TRM=DEL then STR is considered unlimited.
     789    !*   NCH=Length of the string returned in SST or =-1 if NTH is <1 or if
     790    !*   NTH is greater than the number of delimiters in STR.
     791    IMPLICIT INTEGER (A-Z)
     792    CHARACTER STR*(*), DEL*1, TRM*1, SST*(*)
     793    NCH = -1
     794    SST = ' '
     795    IF(NTH>0) THEN
     796      IF(TRM==DEL) THEN
     797        LENGTH = LEN(STR)
     798      ELSE
     799        LENGTH = INDEX(STR, TRM) - 1
     800        IF(LENGTH<0) LENGTH = LEN(STR)
     801      ENDIF
     802      !*     Find beginning and end of the NTH DEL-limited substring in STR
     803      END = -1
     804      DO N = 1, NTH
     805        IF(END==LENGTH) RETURN
     806        BEG = END + 2
     807        END = BEG + INDEX(STR(BEG:LENGTH), DEL) - 2
     808        IF(END==BEG - 2) END = LENGTH
     809        !*        PRINT *,'NTH,LENGTH,N,BEG,END=',NTH,LENGTH,N,BEG,END
     810      end do
     811      NCH = END - BEG + 1
     812      IF(NCH>0) SST = STR(BEG:END)
     813    ENDIF
     814  END
     815  CHARACTER*(*) FUNCTION SPACES(STR, NSPACE)
     816
     817    ! CERN PROGLIB# M433    SPACES          .VERSION KERNFOR  4.14  860211
     818    ! ORIG.  6/05/86 M.GOOSSENS/DD
     819
     820    !-    The function value SPACES returns the character string STR with
     821    !-    leading blanks removed and each occurence of one or more blanks
     822    !-    replaced by NSPACE blanks inside the string STR
     823
     824    CHARACTER*(*) STR
     825    INTEGER nspace
     826
     827    LENSPA = LEN(SPACES)
     828    SPACES = ' '
     829    IF (NSPACE<0) NSPACE = 0
     830    IBLANK = 1
     831    ISPACE = 1
     832    100 INONBL = INDEXC(STR(IBLANK:), ' ')
     833    IF (INONBL==0) THEN
     834      SPACES(ISPACE:) = STR(IBLANK:)
    705835      RETURN
    706       END
    707 
    708       SUBROUTINE corresbis(psol)
    709       implicit none
    710 
    711 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    712 ! Cette subroutine calcule et affiche les valeurs des coefficients
    713 ! d interpolation qui serviront dans la formule d interpolation elle-
    714 ! meme.
    715 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    716 
    717       INTEGER klev    !nombre de niveau de pression du GCM
    718       REAL play(100)  !pression en Pa au milieu de chaque couche GCM
    719       INTEGER JM(100)
    720       REAL coef1(100) !coefficient d interpolation
    721       REAL coef2(100) !coefficient d interpolation
    722 
    723       INTEGER nblvlm !nombre de niveau de pression du mesoNH
    724       REAL playm(100) !pression en Pa milieu de chaque couche Meso-NH
    725       REAL hplaym(100)!pression en hPa des milieux de couche Meso-NH
    726 
    727       COMMON/com1_phys_gcss/play,coef1,coef2,JM,klev
    728       COMMON/com2_phys_gcss/playm,hplaym,nblvlm
    729 
    730       REAL psol
    731       REAL val
    732       INTEGER k, mlz
    733 
    734 
    735       do k=1,klev
    736          val=play(k)
    737        if (val .gt. playm(1)) then
    738           mlz = 0
    739           JM(1) = mlz
    740           coef1(1)=(playm(mlz+1)-val)/(playm(mlz+1)-psol)
    741           coef2(1)=(val-psol)/(playm(mlz+1)-psol)
    742        else if (val .gt. playm(nblvlm)) then
    743          do mlz=1,nblvlm
    744           if (     val .le. playm(mlz).and. val .gt. playm(mlz+1))then
    745            JM(k)=mlz
    746            coef1(k)=(playm(mlz+1)-val)/(playm(mlz+1)-playm(mlz))
    747            coef2(k)=(val-playm(mlz))/(playm(mlz+1)-playm(mlz))
    748           endif
    749          enddo
    750        else
    751          JM(k) = nblvlm-1
    752          coef1(k) = 0.
    753          coef2(k) = 0.
    754        endif
    755       enddo
    756 
    757 !c      if (play(klev) .le. playm(nblvlm)) then
    758 !c         mlz=nblvlm-1
    759 !c         JM(klev)=mlz
    760 !c         coef1(klev)=(playm(mlz+1)-val)
    761 !c     *            /(playm(mlz+1)-playm(mlz))
    762 !c         coef2(klev)=(val-playm(mlz))
    763 !c     *            /(playm(mlz+1)-playm(mlz))
    764 !c      endif
    765 
    766       PRINT*,' '
    767       PRINT*,'         INTERPOLATION  : '
    768       PRINT*,' '
    769       PRINT*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
    770       PRINT*,(JM(k),k=1,klev)
    771       PRINT*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:'
    772       PRINT*,(JM(k),k=1,klev)
    773       PRINT*,' '
    774       PRINT*,'vals du premier coef d"interpolation pour les 9 niveaux: '
    775       PRINT*,(coef1(k),k=1,klev)
    776       PRINT*,' '
    777       PRINT*,'valeurs du deuxieme coef d"interpolation pour les 9 niveaux:'
    778       PRINT*,(coef2(k),k=1,klev)
    779 
    780       return
    781       end
    782       SUBROUTINE GETSCH(STR,DEL,TRM,NTH,SST,NCH)
    783 !***************************************************************
    784 !*                                                             *
    785 !*                                                             *
    786 !* GETSCH                                                      *
    787 !*                                                             *
    788 !*                                                             *
    789 !* modified by :                                               *
    790 !***************************************************************
    791 !*   Return in SST the character string found between the NTH-1 and NTH
    792 !*   occurence of the delimiter 'DEL' but before the terminator 'TRM' in
    793 !*   the input string 'STR'. If TRM=DEL then STR is considered unlimited.
    794 !*   NCH=Length of the string returned in SST or =-1 if NTH is <1 or if
    795 !*   NTH is greater than the number of delimiters in STR.
    796       IMPLICIT INTEGER (A-Z)
    797       CHARACTER STR*(*),DEL*1,TRM*1,SST*(*)
    798       NCH=-1
    799       SST=' '
    800       IF(NTH.GT.0) THEN
    801         IF(TRM.EQ.DEL) THEN
    802           LENGTH=LEN(STR)
    803         ELSE
    804           LENGTH=INDEX(STR,TRM)-1
    805           IF(LENGTH.LT.0) LENGTH=LEN(STR)
    806         ENDIF
    807 !*     Find beginning and end of the NTH DEL-limited substring in STR
    808         END=-1
    809         DO 1,N=1,NTH
    810         IF(END.EQ.LENGTH) RETURN
    811         BEG=END+2
    812         END=BEG+INDEX(STR(BEG:LENGTH),DEL)-2
    813         IF(END.EQ.BEG-2) END=LENGTH
    814 !*        PRINT *,'NTH,LENGTH,N,BEG,END=',NTH,LENGTH,N,BEG,END
    815     1   CONTINUE
    816         NCH=END-BEG+1
    817         IF(NCH.GT.0) SST=STR(BEG:END)
     836    ENDIF
     837    INONBL = INONBL + IBLANK - 1
     838    IBLANK = INDEX(STR(INONBL:), ' ')
     839    IF (IBLANK==0) THEN
     840      SPACES(ISPACE:) = STR(INONBL:)
     841      RETURN
     842    ENDIF
     843    IBLANK = IBLANK + INONBL - 1
     844    SPACES(ISPACE:) = STR(INONBL:IBLANK - 1)
     845    ISPACE = ISPACE + IBLANK - INONBL + NSPACE
     846    IF (ISPACE<=LENSPA)                         GO TO 100
     847  END
     848  INTEGER FUNCTION INDEXC(STR, SSTR)
     849
     850    ! CERN PROGLIB# M433    INDEXC          .VERSION KERNFOR  4.14  860211
     851    ! ORIG. 26/03/86 M.GOOSSENS/DD
     852
     853    !-    Find the leftmost position where substring SSTR does not match
     854    !-    string STR scanning forward
     855
     856    CHARACTER*(*) STR, SSTR
     857    INTEGER I
     858
     859    LENS = LEN(STR)
     860    LENSS = LEN(SSTR)
     861
     862    DO I = 1, LENS - LENSS + 1
     863      IF (STR(I:I + LENSS - 1)/=SSTR) THEN
     864        INDEXC = I
     865        RETURN
    818866      ENDIF
    819       END
    820       CHARACTER*(*) FUNCTION SPACES(STR,NSPACE)
    821 
    822 ! CERN PROGLIB# M433    SPACES          .VERSION KERNFOR  4.14  860211
    823 ! ORIG.  6/05/86 M.GOOSSENS/DD
    824 
    825 !-    The function value SPACES returns the character string STR with
    826 !-    leading blanks removed and each occurence of one or more blanks
    827 !-    replaced by NSPACE blanks inside the string STR
    828 
    829       CHARACTER*(*) STR
    830 
    831       LENSPA = LEN(SPACES)
    832       SPACES = ' '
    833       IF (NSPACE.LT.0) NSPACE = 0
    834       IBLANK = 1
    835       ISPACE = 1
    836   100 INONBL = INDEXC(STR(IBLANK:),' ')
    837       IF (INONBL.EQ.0) THEN
    838           SPACES(ISPACE:) = STR(IBLANK:)
    839                                                     GO TO 999
    840       ENDIF
    841       INONBL = INONBL + IBLANK - 1
    842       IBLANK = INDEX(STR(INONBL:),' ')
    843       IF (IBLANK.EQ.0) THEN
    844           SPACES(ISPACE:) = STR(INONBL:)
    845                                                     GO TO 999
    846       ENDIF
    847       IBLANK = IBLANK + INONBL - 1
    848       SPACES(ISPACE:) = STR(INONBL:IBLANK-1)
    849       ISPACE = ISPACE + IBLANK - INONBL + NSPACE
    850       IF (ISPACE.LE.LENSPA)                         GO TO 100
    851   999 END
    852       FUNCTION INDEXC(STR,SSTR)
    853 
    854 ! CERN PROGLIB# M433    INDEXC          .VERSION KERNFOR  4.14  860211
    855 ! ORIG. 26/03/86 M.GOOSSENS/DD
    856 
    857 !-    Find the leftmost position where substring SSTR does not match
    858 !-    string STR scanning forward
    859 
    860       CHARACTER*(*) STR,SSTR
    861 
    862       LENS   = LEN(STR)
    863       LENSS  = LEN(SSTR)
    864 
    865       DO 10 I=1,LENS-LENSS+1
    866           IF (STR(I:I+LENSS-1).NE.SSTR) THEN
    867               INDEXC = I
    868                                          GO TO 999
    869           ENDIF
    870    10 CONTINUE
    871       INDEXC = 0
    872 
    873   999 END
     867    END DO
     868    INDEXC = 0
     869  END
     870END MODULE lmdz_old_1dconv

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_old_lmdz1d.F90

    r5103 r5104  
    11! $Id: lmdz1d.F90 3540 2019-06-25 14:50:13Z fairhead $
    22
    3 SUBROUTINE old_lmdz1d
    4 
    5   USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar, getin
    6   USE phys_state_var_mod, ONLY: phys_state_var_init, phys_state_var_end, &
    7           clwcon, detr_therm, &
    8           qsol, fevap, z0m, z0h, agesno, &
    9           du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
    10           falb_dir, falb_dif, &
    11           ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
    12           rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
    13           solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, rneb_ancien, &
    14           wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
    15           wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
    16           awake_dens, cv_gen, wake_cstar, &
    17           zgam, zmax0, zmea, zpic, zsig, &
    18           zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, &
    19           prlw_ancien, prsw_ancien, prw_ancien, &
    20           u10m, v10m, ale_wake, ale_bl_stat
    21 
    22   USE dimphy
    23   USE surface_data, ONLY: type_ocean, ok_veget
    24   USE pbl_surface_mod, ONLY: ftsoil, pbl_surface_init, &
    25           pbl_surface_final
    26   USE fonte_neige_mod, ONLY: fonte_neige_init, fonte_neige_final
    27 
    28   USE infotrac ! new
    29   USE control_mod
    30   USE indice_sol_mod
    31   USE phyaqua_mod
    32   !  USE mod_1D_cases_read
    33   USE mod_1D_cases_read2
    34   USE mod_1D_amma_read
    35   USE print_control_mod, ONLY: lunout, prt_level
    36   USE iniphysiq_mod, ONLY: iniphysiq
    37   USE mod_const_mpi, ONLY: comm_lmdz
    38   USE physiq_mod, ONLY: physiq
    39   USE comvert_mod, ONLY: presnivs, ap, bp, dpres, nivsig, nivsigs, pa, &
    40           preff, aps, bps, pseudoalt, scaleheight
    41   USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
    42           itau_dyn, itau_phy, start_time, year_len
    43   USE phys_cal_mod, ONLY: year_len_phys_cal_mod => year_len
    44   USE mod_1D_cases_read, ONLY: interp_case_time ! used in included old_1D_read_forc_cases.h
    45   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
    46 
    47   implicit none
    48   INCLUDE "dimensions.h"
    49   INCLUDE "YOMCST.h"
    50   !!      INCLUDE "control.h"
    51   INCLUDE "clesphys.h"
    52   INCLUDE "dimsoil.h"
    53   !      INCLUDE "indicesol.h"
    54 
    55   INCLUDE "compar1d.h"
    56   INCLUDE "flux_arp.h"
    57   INCLUDE "date_cas.h"
    58   INCLUDE "tsoilnudge.h"
    59   INCLUDE "fcg_gcssold.h"
    60   !!!      INCLUDE "fbforcing.h"
    61   INCLUDE "compbl.h"
    62 
    63   !=====================================================================
    64   ! DECLARATIONS
    65   !=====================================================================
    66 
    67   !---------------------------------------------------------------------
    68   !  Externals
    69   !---------------------------------------------------------------------
    70   external fq_sat
    71   real fq_sat
    72 
    73   !---------------------------------------------------------------------
    74   !  Arguments d' initialisations de la physique (USER DEFINE)
    75   !---------------------------------------------------------------------
    76 
    77   integer, parameter :: ngrid = 1
    78   real :: zcufi = 1.
    79   real :: zcvfi = 1.
    80 
    81   !-      real :: nat_surf
    82   !-      logical :: ok_flux_surf
    83   !-      real :: fsens
    84   !-      real :: flat
    85   !-      real :: tsurf
    86   !-      real :: rugos
    87   !-      real :: qsol(1:2)
    88   !-      real :: qsurf
    89   !-      real :: psurf
    90   !-      real :: zsurf
    91   !-      real :: albedo
    92   !-
    93   !-      real :: time     = 0.
    94   !-      real :: time_ini
    95   !-      real :: xlat
    96   !-      real :: xlon
    97   !-      real :: wtsurf
    98   !-      real :: wqsurf
    99   !-      real :: restart_runoff
    100   !-      real :: xagesno
    101   !-      real :: qsolinp
    102   !-      real :: zpicinp
    103   !-
    104   real :: fnday
    105   real :: day, daytime
    106   real :: day1
    107   real :: heure
    108   integer :: jour
    109   integer :: mois
    110   integer :: an
    111 
    112   !---------------------------------------------------------------------
    113   !  Declarations related to forcing and initial profiles
    114   !---------------------------------------------------------------------
    115 
    116   integer :: kmax = llm
    117   integer llm700, nq1, nq2
    118   INTEGER, PARAMETER :: nlev_max = 1000, nqmx = 1000
    119   real timestep, frac
    120   real height(nlev_max), tttprof(nlev_max), qtprof(nlev_max)
    121   real  uprof(nlev_max), vprof(nlev_max), e12prof(nlev_max)
    122   real  ugprof(nlev_max), vgprof(nlev_max), wfls(nlev_max)
    123   real  dqtdxls(nlev_max), dqtdyls(nlev_max)
    124   real  dqtdtls(nlev_max), thlpcar(nlev_max)
    125   real  qprof(nlev_max, nqmx)
    126 
    127   !        integer :: forcing_type
    128   logical :: forcing_les = .FALSE.
    129   logical :: forcing_armcu = .FALSE.
    130   logical :: forcing_rico = .FALSE.
    131   logical :: forcing_radconv = .FALSE.
    132   logical :: forcing_toga = .FALSE.
    133   logical :: forcing_twpice = .FALSE.
    134   logical :: forcing_amma = .FALSE.
    135   logical :: forcing_dice = .FALSE.
    136   logical :: forcing_gabls4 = .FALSE.
    137 
    138   logical :: forcing_GCM2SCM = .FALSE.
    139   logical :: forcing_GCSSold = .FALSE.
    140   logical :: forcing_sandu = .FALSE.
    141   logical :: forcing_astex = .FALSE.
    142   logical :: forcing_fire = .FALSE.
    143   logical :: forcing_case = .FALSE.
    144   logical :: forcing_case2 = .FALSE.
    145   logical :: forcing_SCM = .FALSE.
    146   integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
    147   !                                                            (cf read_tsurf1d.F)
    148 
    149   real wwww
    150   !vertical advection computation
    151   !       real d_t_z(llm), d_q_z(llm)
    152   !       real d_t_dyn_z(llm), dq_dyn_z(llm)
    153   !       real zz(llm)
    154   !       real zfact
    155 
    156   !flag forcings
    157   logical :: nudge_wind = .TRUE.
    158   logical :: nudge_thermo = .FALSE.
    159   logical :: cptadvw = .TRUE.
    160   !=====================================================================
    161   ! DECLARATIONS FOR EACH CASE
    162   !=====================================================================
    163 
    164   INCLUDE "old_1D_decl_cases.h"
    165 
    166   !---------------------------------------------------------------------
    167   !  Declarations related to nudging
    168   !---------------------------------------------------------------------
    169   integer :: nudge_max
    170   parameter (nudge_max = 9)
    171   integer :: inudge_RHT = 1
    172   integer :: inudge_UV = 2
    173   logical :: nudge(nudge_max)
    174   real :: t_targ(llm)
    175   real :: rh_targ(llm)
    176   real :: u_targ(llm)
    177   real :: v_targ(llm)
    178 
    179   !---------------------------------------------------------------------
    180   !  Declarations related to vertical discretization:
    181   !---------------------------------------------------------------------
    182   real :: pzero = 1.e5
    183   real :: play (llm), zlay (llm), sig_s(llm), plev(llm + 1)
    184   real :: playd(llm), zlayd(llm), ap_amma(llm + 1), bp_amma(llm + 1)
    185 
    186   !---------------------------------------------------------------------
    187   !  Declarations related to variables
    188   !---------------------------------------------------------------------
    189 
    190   real :: phi(llm)
    191   real :: teta(llm), tetal(llm), temp(llm), u(llm), v(llm), w(llm)
    192   REAL rot(1, llm) ! relative vorticity, in s-1
    193   real :: rlat_rad(1), rlon_rad(1)
    194   real :: omega(llm + 1), omega2(llm), rho(llm + 1)
    195   real :: ug(llm), vg(llm), fcoriolis
    196   real :: sfdt, cfdt
    197   real :: du_phys(llm), dv_phys(llm), dt_phys(llm)
    198   real :: dt_dyn(llm)
    199   real :: dt_cooling(llm), d_t_adv(llm), d_t_nudge(llm)
    200   real :: d_u_nudge(llm), d_v_nudge(llm)
    201   real :: du_adv(llm), dv_adv(llm)
    202   real :: du_age(llm), dv_age(llm)
    203   real :: alpha
    204   real :: ttt
    205 
    206   REAL, ALLOCATABLE, DIMENSION(:, :) :: q
    207   REAL, ALLOCATABLE, DIMENSION(:, :) :: dq
    208   REAL, ALLOCATABLE, DIMENSION(:, :) :: dq_dyn
    209   REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_adv
    210   REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_nudge
    211   !      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
    212 
    213   !---------------------------------------------------------------------
    214   !  Initialization of surface variables
    215   !---------------------------------------------------------------------
    216   real :: run_off_lic_0(1)
    217   real :: fder(1), snsrf(1, nbsrf), qsurfsrf(1, nbsrf)
    218   real :: tsoil(1, nsoilmx, nbsrf)
    219   !     real :: agesno(1,nbsrf)
    220 
    221   !---------------------------------------------------------------------
    222   !  Call to phyredem
    223   !---------------------------------------------------------------------
    224   logical :: ok_writedem = .TRUE.
    225   real :: sollw_in = 0.
    226   real :: solsw_in = 0.
    227 
    228   !---------------------------------------------------------------------
    229   !  Call to physiq
    230   !---------------------------------------------------------------------
    231   logical :: firstcall = .TRUE.
    232   logical :: lastcall = .FALSE.
    233   real :: phis(1) = 0.0
    234   real :: dpsrf(1)
    235 
    236   !---------------------------------------------------------------------
    237   !  Initializations of boundary conditions
    238   !---------------------------------------------------------------------
    239   real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
    240   real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
    241   real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
    242   real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
    243   real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
    244   real, allocatable :: phy_ice (:) ! Fraction de glace
    245   real, allocatable :: phy_fter(:) ! Fraction de terre
    246   real, allocatable :: phy_foce(:) ! Fraction de ocean
    247   real, allocatable :: phy_fsic(:) ! Fraction de glace
    248   real, allocatable :: phy_flic(:) ! Fraction de glace
    249 
    250   !---------------------------------------------------------------------
    251   !  Fichiers et d'autres variables
    252   !---------------------------------------------------------------------
    253   integer :: k, l, i, it = 1, mxcalc
    254   integer :: nsrf
    255   integer jcode
    256   INTEGER read_climoz
    257 
    258   integer :: it_end ! iteration number of the last call
    259   !Al1
    260   integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
    261   data ecrit_slab_oc/-1/
    262 
    263   !     if flag_inhib_forcing = 0, tendencies of forcing are added
    264   !                           <> 0, tendencies of forcing are not added
    265   INTEGER :: flag_inhib_forcing = 0
    266 
    267   !=====================================================================
    268   ! INITIALIZATIONS
    269   !=====================================================================
    270   du_phys(:) = 0.
    271   dv_phys(:) = 0.
    272   dt_phys(:) = 0.
    273   dt_dyn(:) = 0.
    274   dt_cooling(:) = 0.
    275   d_t_adv(:) = 0.
    276   d_t_nudge(:) = 0.
    277   d_u_nudge(:) = 0.
    278   d_v_nudge(:) = 0.
    279   du_adv(:) = 0.
    280   dv_adv(:) = 0.
    281   du_age(:) = 0.
    282   dv_age(:) = 0.
    283 
    284   ! Initialization of Common turb_forcing
    285   dtime_frcg = 0.
    286   Turb_fcg_gcssold = .FALSE.
    287   hthturb_gcssold = 0.
    288   hqturb_gcssold = 0.
    289 
    290 
    291 
    292 
    293   !---------------------------------------------------------------------
    294   ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
    295   !---------------------------------------------------------------------
    296   !Al1
    297   CALL conf_unicol
    298   !Al1 moves this gcssold var from common fcg_gcssold to
    299   Turb_fcg_gcssold = xTurb_fcg_gcssold
    300   ! --------------------------------------------------------------------
    301   close(1)
    302   !Al1
    303   write(*, *) 'lmdz1d.def lu => unicol.def'
    304 
    305   ! forcing_type defines the way the SCM is forced:
    306   !forcing_type = 0 ==> forcing_les = .TRUE.
    307   !             initial profiles from file prof.inp.001
    308   !             no forcing by LS convergence ;
    309   !             surface temperature imposed ;
    310   !             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
    311   !forcing_type = 1 ==> forcing_radconv = .TRUE.
    312   !             idem forcing_type = 0, but the imposed radiative cooling
    313   !             is set to 0 (hence, if iflag_radia=0 in physiq.def,
    314   !             then there is no radiative cooling at all)
    315   !forcing_type = 2 ==> forcing_toga = .TRUE.
    316   !             initial profiles from TOGA-COARE IFA files
    317   !             LS convergence and SST imposed from TOGA-COARE IFA files
    318   !forcing_type = 3 ==> forcing_GCM2SCM = .TRUE.
    319   !             initial profiles from the GCM output
    320   !             LS convergence imposed from the GCM output
    321   !forcing_type = 4 ==> forcing_twpice = .TRUE.
    322   !             initial profiles from TWP-ICE cdf file
    323   !             LS convergence, omega and SST imposed from TWP-ICE files
    324   !forcing_type = 5 ==> forcing_rico = .TRUE.
    325   !             initial profiles from RICO files
    326   !             LS convergence imposed from RICO files
    327   !forcing_type = 6 ==> forcing_amma = .TRUE.
    328   !             initial profiles from AMMA nc file
    329   !             LS convergence, omega and surface fluxes imposed from AMMA file
    330   !forcing_type = 7 ==> forcing_dice = .TRUE.
    331   !             initial profiles and large scale forcings in dice_driver.nc
    332   !             Different stages: soil model alone, atm. model alone
    333   !             then both models coupled
    334   !forcing_type = 8 ==> forcing_gabls4 = .TRUE.
    335   !             initial profiles and large scale forcings in gabls4_driver.nc
    336   !forcing_type >= 100 ==> forcing_case = .TRUE.
    337   !             initial profiles and large scale forcings in cas.nc
    338   !             LS convergence, omega and SST imposed from CINDY-DYNAMO files
    339   !             101=cindynamo
    340   !             102=bomex
    341   !forcing_type >= 100 ==> forcing_case2 = .TRUE.
    342   !             temporary flag while all the 1D cases are not whith the same cas.nc forcing file
    343   !             103=arm_cu2 ie arm_cu with new forcing format
    344   !             104=rico2 ie rico with new forcing format
    345   !forcing_type = 40 ==> forcing_GCSSold = .TRUE.
    346   !             initial profile from GCSS file
    347   !             LS convergence imposed from GCSS file
    348   !forcing_type = 50 ==> forcing_fire = .TRUE.
    349   !             forcing from fire.nc
    350   !forcing_type = 59 ==> forcing_sandu = .TRUE.
    351   !             initial profiles from sanduref file: see prof.inp.001
    352   !             SST varying with time and divergence constante: see ifa_sanduref.txt file
    353   !             Radiation has to be computed interactively
    354   !forcing_type = 60 ==> forcing_astex = .TRUE.
    355   !             initial profiles from file: see prof.inp.001
    356   !             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
    357   !             Radiation has to be computed interactively
    358   !forcing_type = 61 ==> forcing_armcu = .TRUE.
    359   !             initial profiles from file: see prof.inp.001
    360   !             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
    361   !             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
    362   !             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s
    363   !             Radiation to be switched off
    364 
    365   if (forcing_type <=0) THEN
    366     forcing_les = .TRUE.
    367   elseif (forcing_type ==1) THEN
    368     forcing_radconv = .TRUE.
    369   elseif (forcing_type ==2) THEN
    370     forcing_toga = .TRUE.
    371   elseif (forcing_type ==3) THEN
    372     forcing_GCM2SCM = .TRUE.
    373   elseif (forcing_type ==4) THEN
    374     forcing_twpice = .TRUE.
    375   elseif (forcing_type ==5) THEN
    376     forcing_rico = .TRUE.
    377   elseif (forcing_type ==6) THEN
    378     forcing_amma = .TRUE.
    379   elseif (forcing_type ==7) THEN
    380     forcing_dice = .TRUE.
    381   elseif (forcing_type ==8) THEN
    382     forcing_gabls4 = .TRUE.
    383   elseif (forcing_type ==101) THEN ! Cindynamo starts 1-10-2011 0h
    384     forcing_case = .TRUE.
    385     year_ini_cas = 2011
    386     mth_ini_cas = 10
    387     day_deb = 1
    388     heure_ini_cas = 0.
    389     pdt_cas = 3 * 3600.         ! forcing frequency
    390   elseif (forcing_type ==102) THEN ! Bomex starts 24-6-1969 0h
    391     forcing_case = .TRUE.
    392     year_ini_cas = 1969
    393     mth_ini_cas = 6
    394     day_deb = 24
    395     heure_ini_cas = 0.
    396     pdt_cas = 1800.         ! forcing frequency
    397   elseif (forcing_type ==103) THEN ! Arm_cu starts 21-6-1997 11h30
    398     forcing_case2 = .TRUE.
    399     year_ini_cas = 1997
    400     mth_ini_cas = 6
    401     day_deb = 21
    402     heure_ini_cas = 11.5
    403     pdt_cas = 1800.         ! forcing frequency
    404   elseif (forcing_type ==104) THEN ! rico starts 16-12-2004 0h
    405     forcing_case2 = .TRUE.
    406     year_ini_cas = 2004
    407     mth_ini_cas = 12
    408     day_deb = 16
    409     heure_ini_cas = 0.
    410     pdt_cas = 1800.         ! forcing frequency
    411   elseif (forcing_type ==105) THEN ! bomex starts 16-12-2004 0h
    412     forcing_case2 = .TRUE.
    413     year_ini_cas = 1969
    414     mth_ini_cas = 6
    415     day_deb = 24
    416     heure_ini_cas = 0.
    417     pdt_cas = 1800.         ! forcing frequency
    418   elseif (forcing_type ==106) THEN ! ayotte_24SC starts 6-11-1992 0h
    419     forcing_case2 = .TRUE.
    420     year_ini_cas = 1992
    421     mth_ini_cas = 11
    422     day_deb = 6
    423     heure_ini_cas = 10.
    424     pdt_cas = 86400.        ! forcing frequency
    425   elseif (forcing_type ==113) THEN ! Arm_cu starts 21-6-1997 11h30
    426     forcing_SCM = .TRUE.
    427     year_ini_cas = 1997
    428     ! It is possible that those parameters are run twice.
    429     CALL getin('anneeref', year_ini_cas)
    430     CALL getin('dayref', day_deb)
    431     mth_ini_cas = 1 ! pour le moment on compte depuis le debut de l'annee
    432     CALL getin('time_ini', heure_ini_cas)
    433   elseif (forcing_type ==40) THEN
    434     forcing_GCSSold = .TRUE.
    435   elseif (forcing_type ==50) THEN
    436     forcing_fire = .TRUE.
    437   elseif (forcing_type ==59) THEN
    438     forcing_sandu = .TRUE.
    439   elseif (forcing_type ==60) THEN
    440     forcing_astex = .TRUE.
    441   elseif (forcing_type ==61) THEN
    442     forcing_armcu = .TRUE.
    443     IF(llm/=19.AND.llm/=40) stop 'Erreur nombre de niveaux !!'
    444   else
    445     write (*, *) 'ERROR : unknown forcing_type ', forcing_type
    446     stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'
    447   ENDIF
    448   PRINT*, "forcing type=", forcing_type
    449 
    450   ! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time
    451   ! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature
    452   ! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F
    453   ! through the common sst_forcing.
    454 
    455   type_ts_forcing = 0
    456   if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice)                 &
    457           type_ts_forcing = 1
    458 
    459   ! Initialization of the logical switch for nudging
    460   jcode = iflag_nudge
    461   do i = 1, nudge_max
    462     nudge(i) = mod(jcode, 10) >= 1
    463     jcode = jcode / 10
    464   enddo
    465   !---------------------------------------------------------------------
    466   !  Definition of the run
    467   !---------------------------------------------------------------------
    468 
    469   CALL conf_gcm(99, .TRUE.)
    470 
    471   !-----------------------------------------------------------------------
    472   allocate(phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
    473   phy_nat(:) = 0.0
    474   allocate(phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
    475   allocate(phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
    476   allocate(phy_bil (year_len))  ! Ne sert que pour les slab_ocean
    477   phy_bil(:) = 1.0
    478   allocate(phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
    479   allocate(phy_ice (year_len)) ! Fraction de glace
    480   phy_ice(:) = 0.0
    481   allocate(phy_fter(year_len)) ! Fraction de terre
    482   phy_fter(:) = 0.0
    483   allocate(phy_foce(year_len)) ! Fraction de ocean
    484   phy_foce(:) = 0.0
    485   allocate(phy_fsic(year_len)) ! Fraction de glace
    486   phy_fsic(:) = 0.0
    487   allocate(phy_flic(year_len)) ! Fraction de glace
    488   phy_flic(:) = 0.0
    489   !-----------------------------------------------------------------------
    490   !   Choix du calendrier
    491   !   -------------------
    492 
    493   !      calend = 'earth_365d'
    494   if (calend == 'earth_360d') then
    495     CALL ioconf_calendar('360_day')
    496     write(*, *)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
    497   else if (calend == 'earth_365d') then
    498     CALL ioconf_calendar('noleap')
    499     write(*, *)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
    500   else if (calend == 'earth_366d') then
    501     CALL ioconf_calendar('all_leap')
    502     write(*, *)'CALENDRIER CHOISI: Terrestre bissextile'
    503   else if (calend == 'gregorian') then
    504     stop 'gregorian calend should not be used by normal user'
    505     CALL ioconf_calendar('gregorian') ! not to be used by normal users
    506     write(*, *)'CALENDRIER CHOISI: Gregorien'
    507   else
    508     write (*, *) 'ERROR : unknown calendar ', calend
    509     stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
    510   endif
    511   !-----------------------------------------------------------------------
    512 
    513   !c Date :
    514   !      La date est supposee donnee sous la forme [annee, numero du jour dans
    515   !      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
    516   !      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
    517   !      Le numero du jour est dans "day". L heure est traitee separement.
    518   !      La date complete est dans "daytime" (l'unite est le jour).
    519   if (nday>0) then
    520     fnday = nday
    521   else
    522     fnday = -nday / float(day_step)
    523   endif
    524   print *, 'fnday=', fnday
    525   !     start_time doit etre en FRACTION DE JOUR
    526   start_time = time_ini / 24.
    527 
    528   ! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
    529   IF(forcing_type == 61) fnday = 53100. / 86400.
    530   IF(forcing_type == 103) fnday = 53100. / 86400.
    531   ! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)
    532   IF(forcing_type == 6) fnday = 64800. / 86400.
    533   !     IF(forcing_type .EQ. 6) fnday=50400./86400.
    534   IF(forcing_type == 8) fnday = 129600. / 86400.
    535   annee_ref = anneeref
    536   mois = 1
    537   day_ref = dayref
    538   heure = 0.
    539   itau_dyn = 0
    540   itau_phy = 0
    541   CALL ymds2ju(annee_ref, mois, day_ref, heure, day)
    542   day_ini = int(day)
    543   day_end = day_ini + int(fnday)
    544 
    545   IF (forcing_type ==2) THEN
    546     ! Convert the initial date of Toga-Coare to Julian day
    547     CALL ymds2ju                                                          &
    548             (year_ini_toga, mth_ini_toga, day_ini_toga, heure, day_ju_ini_toga)
    549 
    550   ELSEIF (forcing_type ==4) THEN
    551     ! Convert the initial date of TWPICE to Julian day
    552     CALL ymds2ju                                                          &
    553             (year_ini_twpi, mth_ini_twpi, day_ini_twpi, heure_ini_twpi              &
    554             , day_ju_ini_twpi)
    555   ELSEIF (forcing_type ==6) THEN
    556     ! Convert the initial date of AMMA to Julian day
    557     CALL ymds2ju                                                          &
    558             (year_ini_amma, mth_ini_amma, day_ini_amma, heure_ini_amma              &
    559             , day_ju_ini_amma)
    560   ELSEIF (forcing_type ==7) THEN
    561     ! Convert the initial date of DICE to Julian day
    562     CALL ymds2ju                                                         &
    563             (year_ini_dice, mth_ini_dice, day_ini_dice, heure_ini_dice             &
    564             , day_ju_ini_dice)
    565   ELSEIF (forcing_type ==8) THEN
    566     ! Convert the initial date of GABLS4 to Julian day
    567     CALL ymds2ju                                                         &
    568             (year_ini_gabls4, mth_ini_gabls4, day_ini_gabls4, heure_ini_gabls4     &
    569             , day_ju_ini_gabls4)
    570   ELSEIF (forcing_type >100) THEN
    571     ! Convert the initial date to Julian day
    572     day_ini_cas = day_deb
    573     PRINT*, 'time case', year_ini_cas, mth_ini_cas, day_ini_cas
    574     CALL ymds2ju                                                         &
    575             (year_ini_cas, mth_ini_cas, day_ini_cas, heure_ini_cas * 3600            &
    576             , day_ju_ini_cas)
    577     PRINT*, 'time case 2', day_ini_cas, day_ju_ini_cas
    578   ELSEIF (forcing_type ==59) THEN
    579     ! Convert the initial date of Sandu case to Julian day
    580     CALL ymds2ju                                                          &
    581             (year_ini_sandu, mth_ini_sandu, day_ini_sandu, &
    582             time_ini * 3600., day_ju_ini_sandu)
    583 
    584   ELSEIF (forcing_type ==60) THEN
    585     ! Convert the initial date of Astex case to Julian day
    586     CALL ymds2ju                                                          &
    587             (year_ini_astex, mth_ini_astex, day_ini_astex, &
    588             time_ini * 3600., day_ju_ini_astex)
    589 
    590   ELSEIF (forcing_type ==61) THEN
    591     ! Convert the initial date of Arm_cu case to Julian day
    592     CALL ymds2ju                                                          &
    593             (year_ini_armcu, mth_ini_armcu, day_ini_armcu, heure_ini_armcu          &
    594             , day_ju_ini_armcu)
    595   ENDIF
    596 
    597   IF (forcing_type >100) THEN
    598     daytime = day + heure_ini_cas / 24. ! 1st day and initial time of the simulation
    599   ELSE
    600     daytime = day + time_ini / 24. ! 1st day and initial time of the simulation
    601   ENDIF
    602   ! Print out the actual date of the beginning of the simulation :
    603   CALL ju2ymds(daytime, year_print, month_print, day_print, sec_print)
    604   print *, ' Time of beginning : ', &
    605           year_print, month_print, day_print, sec_print
    606 
    607   !---------------------------------------------------------------------
    608   ! Initialization of dimensions, geometry and initial state
    609   !---------------------------------------------------------------------
    610   !      CALL init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
    611   !     but we still need to initialize dimphy module (klon,klev,etc.)  here.
    612   CALL init_dimphy1D(1, llm)
    613   CALL suphel
    614   CALL init_infotrac
    615 
    616   if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
    617   allocate(q(llm, nqtot)) ; q(:, :) = 0.
    618   allocate(dq(llm, nqtot))
    619   allocate(dq_dyn(llm, nqtot))
    620   allocate(d_q_adv(llm, nqtot))
    621   allocate(d_q_nudge(llm, nqtot))
    622   !      allocate(d_th_adv(llm))
    623 
    624   q(:, :) = 0.
    625   dq(:, :) = 0.
    626   dq_dyn(:, :) = 0.
    627   d_q_adv(:, :) = 0.
    628   d_q_nudge(:, :) = 0.
    629 
    630   !   No ozone climatology need be read in this pre-initialization
    631   !          (phys_state_var_init is called again in physiq)
    632   read_climoz = 0
    633   nsw = 6          ! EV et LF: sinon, falb_dir et falb_dif ne peuvent etre alloues
    634 
    635   CALL phys_state_var_init(read_climoz)
    636 
    637   if (ngrid/=klon) then
    638     PRINT*, 'stop in inifis'
    639     PRINT*, 'Probleme de dimensions :'
    640     PRINT*, 'ngrid = ', ngrid
    641     PRINT*, 'klon  = ', klon
    642     stop
    643   endif
    644   !!!=====================================================================
    645   !!! Feedback forcing values for Gateaux differentiation (al1)
    646   !!!=====================================================================
    647   !!! Surface Planck forcing bracketing CALL radiation
    648   !!      surf_Planck = 0.
    649   !!      surf_Conv   = 0.
    650   !!      write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv
    651   !!! a mettre dans le lmdz1d.def ou autre
    652   !!
    653   !!
    654   qsol = qsolinp
    655   qsurf = fq_sat(tsurf, psurf / 100.)
    656   beta_surf = 1.
    657   beta_aridity(:, :) = beta_surf
    658   day1 = day_ini
    659   time = daytime - day
    660   ts_toga(1) = tsurf ! needed by read_tsurf1d.F
    661   rho(1) = psurf / (rd * tsurf * (1. + (rv / rd - 1.) * qsurf))
    662 
    663   !! mpl et jyg le 22/08/2012 :
    664   !!  pour que les cas a flux de surface imposes marchent
    665   IF(.NOT.ok_flux_surf.or.max(abs(wtsurf), abs(wqsurf))>0.) THEN
    666     fsens = -wtsurf * rcpd * rho(1)
    667     flat = -wqsurf * rlvtt * rho(1)
    668     print *, 'Flux: ok_flux wtsurf wqsurf', ok_flux_surf, wtsurf, wqsurf
    669   ENDIF
    670   PRINT*, 'Flux sol ', fsens, flat
    671   !!      ok_flux_surf=.FALSE.
    672   !!      fsens=-wtsurf*rcpd*rho(1)
    673   !!      flat=-wqsurf*rlvtt*rho(1)
    674   !!!!
    675 
    676   ! Vertical discretization and pressure levels at half and mid levels:
    677 
    678   pa = 5e4
    679   !!      preff= 1.01325e5
    680   preff = psurf
    681   IF (ok_old_disvert) THEN
    682     CALL disvert0(pa, preff, ap, bp, dpres, presnivs, nivsigs, nivsig)
    683     print *, 'On utilise disvert0'
    684     aps(1:llm) = 0.5 * (ap(1:llm) + ap(2:llm + 1))
    685     bps(1:llm) = 0.5 * (bp(1:llm) + bp(2:llm + 1))
    686     scaleheight = 8.
    687     pseudoalt(1:llm) = -scaleheight * log(presnivs(1:llm) / preff)
    688   ELSE
    689     CALL disvert()
    690     print *, 'On utilise disvert'
    691     !       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
    692     !       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
    693   ENDIF
    694 
    695   sig_s = presnivs / preff
    696   plev = ap + bp * psurf
    697   play = 0.5 * (plev(1:llm) + plev(2:llm + 1))
    698   zlay = -rd * 300. * log(play / psurf) / rg ! moved after reading profiles
    699 
    700   IF (forcing_type == 59) THEN
    701     ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
    702     write(*, *) '***********************'
    703     do l = 1, llm
    704       write(*, *) 'l,play(l),presnivs(l): ', l, play(l), presnivs(l)
    705       if (trouve_700 .and. play(l)<=70000) then
    706         llm700 = l
    707         print *, 'llm700,play=', llm700, play(l) / 100.
    708         trouve_700 = .FALSE.
    709       endif
     3MODULE lmdz_old_lmdz1d
     4  IMPLICIT NONE; PRIVATE
     5  PUBLIC old_lmdz1d
     6CONTAINS
     7
     8  SUBROUTINE old_lmdz1d
     9
     10    USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar, getin
     11    USE phys_state_var_mod, ONLY: phys_state_var_init, phys_state_var_end, &
     12            clwcon, detr_therm, &
     13            qsol, fevap, z0m, z0h, agesno, &
     14            du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
     15            falb_dir, falb_dif, &
     16            ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
     17            rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
     18            solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, rneb_ancien, &
     19            wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
     20            wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
     21            awake_dens, cv_gen, wake_cstar, &
     22            zgam, zmax0, zmea, zpic, zsig, &
     23            zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, &
     24            prlw_ancien, prsw_ancien, prw_ancien, &
     25            u10m, v10m, ale_wake, ale_bl_stat
     26
     27    USE dimphy
     28    USE surface_data, ONLY: type_ocean, ok_veget
     29    USE pbl_surface_mod, ONLY: ftsoil, pbl_surface_init, pbl_surface_final
     30    USE fonte_neige_mod, ONLY: fonte_neige_init, fonte_neige_final
     31
     32    USE infotrac
     33    USE control_mod
     34    USE indice_sol_mod
     35    USE phyaqua_mod
     36    USE mod_1D_cases_read2
     37    USE mod_1D_amma_read
     38    USE print_control_mod, ONLY: lunout, prt_level
     39    USE iniphysiq_mod, ONLY: iniphysiq
     40    USE mod_const_mpi, ONLY: comm_lmdz
     41    USE physiq_mod, ONLY: physiq
     42    USE comvert_mod, ONLY: presnivs, ap, bp, dpres, nivsig, nivsigs, pa, &
     43            preff, aps, bps, pseudoalt, scaleheight
     44    USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
     45            itau_dyn, itau_phy, start_time, year_len
     46    USE phys_cal_mod, ONLY: year_len_phys_cal_mod => year_len
     47    USE mod_1D_cases_read, ONLY: interp_case_time ! used in included old_1D_read_forc_cases.h
     48    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
     49    USE lmdz_1dutils, ONLY: fq_sat, conf_unicol, dyn1deta0, dyn1dredem
     50
     51    INCLUDE "dimensions.h"
     52    INCLUDE "YOMCST.h"
     53    INCLUDE "clesphys.h"
     54    INCLUDE "dimsoil.h"
     55    INCLUDE "compar1d.h"
     56    INCLUDE "flux_arp.h"
     57    INCLUDE "date_cas.h"
     58    INCLUDE "tsoilnudge.h"
     59    INCLUDE "fcg_gcssold.h"
     60    INCLUDE "compbl.h"
     61
     62    !=====================================================================
     63    ! DECLARATIONS
     64    !=====================================================================
     65    !---------------------------------------------------------------------
     66    !  Arguments d' initialisations de la physique (USER DEFINE)
     67    !---------------------------------------------------------------------
     68
     69    integer, parameter :: ngrid = 1
     70    real :: zcufi = 1.
     71    real :: zcvfi = 1.
     72
     73    !-      real :: nat_surf
     74    !-      logical :: ok_flux_surf
     75    !-      real :: fsens
     76    !-      real :: flat
     77    !-      real :: tsurf
     78    !-      real :: rugos
     79    !-      real :: qsol(1:2)
     80    !-      real :: qsurf
     81    !-      real :: psurf
     82    !-      real :: zsurf
     83    !-      real :: albedo
     84    !-
     85    !-      real :: time     = 0.
     86    !-      real :: time_ini
     87    !-      real :: xlat
     88    !-      real :: xlon
     89    !-      real :: wtsurf
     90    !-      real :: wqsurf
     91    !-      real :: restart_runoff
     92    !-      real :: xagesno
     93    !-      real :: qsolinp
     94    !-      real :: zpicinp
     95    !-
     96    real :: fnday
     97    real :: day, daytime
     98    real :: day1
     99    real :: heure
     100    integer :: jour
     101    integer :: mois
     102    integer :: an
     103
     104    !---------------------------------------------------------------------
     105    !  Declarations related to forcing and initial profiles
     106    !---------------------------------------------------------------------
     107
     108    integer :: kmax = llm
     109    integer llm700, nq1, nq2
     110    INTEGER, PARAMETER :: nlev_max = 1000, nqmx = 1000
     111    real timestep, frac
     112    real height(nlev_max), tttprof(nlev_max), qtprof(nlev_max)
     113    real  uprof(nlev_max), vprof(nlev_max), e12prof(nlev_max)
     114    real  ugprof(nlev_max), vgprof(nlev_max), wfls(nlev_max)
     115    real  dqtdxls(nlev_max), dqtdyls(nlev_max)
     116    real  dqtdtls(nlev_max), thlpcar(nlev_max)
     117    real  qprof(nlev_max, nqmx)
     118
     119    !        integer :: forcing_type
     120    logical :: forcing_les = .FALSE.
     121    logical :: forcing_armcu = .FALSE.
     122    logical :: forcing_rico = .FALSE.
     123    logical :: forcing_radconv = .FALSE.
     124    logical :: forcing_toga = .FALSE.
     125    logical :: forcing_twpice = .FALSE.
     126    logical :: forcing_amma = .FALSE.
     127    logical :: forcing_dice = .FALSE.
     128    logical :: forcing_gabls4 = .FALSE.
     129
     130    logical :: forcing_GCM2SCM = .FALSE.
     131    logical :: forcing_GCSSold = .FALSE.
     132    logical :: forcing_sandu = .FALSE.
     133    logical :: forcing_astex = .FALSE.
     134    logical :: forcing_fire = .FALSE.
     135    logical :: forcing_case = .FALSE.
     136    logical :: forcing_case2 = .FALSE.
     137    logical :: forcing_SCM = .FALSE.
     138    integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
     139    !                                                            (cf read_tsurf1d.F)
     140
     141    real wwww
     142    !vertical advection computation
     143    !       real d_t_z(llm), d_q_z(llm)
     144    !       real d_t_dyn_z(llm), dq_dyn_z(llm)
     145    !       real zz(llm)
     146    !       real zfact
     147
     148    !flag forcings
     149    logical :: nudge_wind = .TRUE.
     150    logical :: nudge_thermo = .FALSE.
     151    logical :: cptadvw = .TRUE.
     152    !=====================================================================
     153    ! DECLARATIONS FOR EACH CASE
     154    !=====================================================================
     155
     156    INCLUDE "old_1D_decl_cases.h"
     157
     158    !---------------------------------------------------------------------
     159    !  Declarations related to nudging
     160    !---------------------------------------------------------------------
     161    integer :: nudge_max
     162    parameter (nudge_max = 9)
     163    integer :: inudge_RHT = 1
     164    integer :: inudge_UV = 2
     165    logical :: nudge(nudge_max)
     166    real :: t_targ(llm)
     167    real :: rh_targ(llm)
     168    real :: u_targ(llm)
     169    real :: v_targ(llm)
     170
     171    !---------------------------------------------------------------------
     172    !  Declarations related to vertical discretization:
     173    !---------------------------------------------------------------------
     174    real :: pzero = 1.e5
     175    real :: play (llm), zlay (llm), sig_s(llm), plev(llm + 1)
     176    real :: playd(llm), zlayd(llm), ap_amma(llm + 1), bp_amma(llm + 1)
     177
     178    !---------------------------------------------------------------------
     179    !  Declarations related to variables
     180    !---------------------------------------------------------------------
     181
     182    real :: phi(llm)
     183    real :: teta(llm), tetal(llm), temp(llm), u(llm), v(llm), w(llm)
     184    REAL rot(1, llm) ! relative vorticity, in s-1
     185    real :: rlat_rad(1), rlon_rad(1)
     186    real :: omega(llm + 1), omega2(llm), rho(llm + 1)
     187    real :: ug(llm), vg(llm), fcoriolis
     188    real :: sfdt, cfdt
     189    real :: du_phys(llm), dv_phys(llm), dt_phys(llm)
     190    real :: dt_dyn(llm)
     191    real :: dt_cooling(llm), d_t_adv(llm), d_t_nudge(llm)
     192    real :: d_u_nudge(llm), d_v_nudge(llm)
     193    real :: du_adv(llm), dv_adv(llm)
     194    real :: du_age(llm), dv_age(llm)
     195    real :: alpha
     196    real :: ttt
     197
     198    REAL, ALLOCATABLE, DIMENSION(:, :) :: q
     199    REAL, ALLOCATABLE, DIMENSION(:, :) :: dq
     200    REAL, ALLOCATABLE, DIMENSION(:, :) :: dq_dyn
     201    REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_adv
     202    REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_nudge
     203    !      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
     204
     205    !---------------------------------------------------------------------
     206    !  Initialization of surface variables
     207    !---------------------------------------------------------------------
     208    real :: run_off_lic_0(1)
     209    real :: fder(1), snsrf(1, nbsrf), qsurfsrf(1, nbsrf)
     210    real :: tsoil(1, nsoilmx, nbsrf)
     211    !     real :: agesno(1,nbsrf)
     212
     213    !---------------------------------------------------------------------
     214    !  Call to phyredem
     215    !---------------------------------------------------------------------
     216    logical :: ok_writedem = .TRUE.
     217    real :: sollw_in = 0.
     218    real :: solsw_in = 0.
     219
     220    !---------------------------------------------------------------------
     221    !  Call to physiq
     222    !---------------------------------------------------------------------
     223    logical :: firstcall = .TRUE.
     224    logical :: lastcall = .FALSE.
     225    real :: phis(1) = 0.0
     226    real :: dpsrf(1)
     227
     228    !---------------------------------------------------------------------
     229    !  Initializations of boundary conditions
     230    !---------------------------------------------------------------------
     231    real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
     232    real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
     233    real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
     234    real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
     235    real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
     236    real, allocatable :: phy_ice (:) ! Fraction de glace
     237    real, allocatable :: phy_fter(:) ! Fraction de terre
     238    real, allocatable :: phy_foce(:) ! Fraction de ocean
     239    real, allocatable :: phy_fsic(:) ! Fraction de glace
     240    real, allocatable :: phy_flic(:) ! Fraction de glace
     241
     242    !---------------------------------------------------------------------
     243    !  Fichiers et d'autres variables
     244    !---------------------------------------------------------------------
     245    integer :: k, l, i, it = 1, mxcalc
     246    integer :: nsrf
     247    integer jcode
     248    INTEGER read_climoz
     249
     250    integer :: it_end ! iteration number of the last call
     251    !Al1
     252    integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
     253    data ecrit_slab_oc/-1/
     254
     255    !     if flag_inhib_forcing = 0, tendencies of forcing are added
     256    !                           <> 0, tendencies of forcing are not added
     257    INTEGER :: flag_inhib_forcing = 0
     258
     259    !=====================================================================
     260    ! INITIALIZATIONS
     261    !=====================================================================
     262    du_phys(:) = 0.
     263    dv_phys(:) = 0.
     264    dt_phys(:) = 0.
     265    dt_dyn(:) = 0.
     266    dt_cooling(:) = 0.
     267    d_t_adv(:) = 0.
     268    d_t_nudge(:) = 0.
     269    d_u_nudge(:) = 0.
     270    d_v_nudge(:) = 0.
     271    du_adv(:) = 0.
     272    dv_adv(:) = 0.
     273    du_age(:) = 0.
     274    dv_age(:) = 0.
     275
     276    ! Initialization of Common turb_forcing
     277    dtime_frcg = 0.
     278    Turb_fcg_gcssold = .FALSE.
     279    hthturb_gcssold = 0.
     280    hqturb_gcssold = 0.
     281
     282
     283
     284
     285    !---------------------------------------------------------------------
     286    ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
     287    !---------------------------------------------------------------------
     288    !Al1
     289    CALL conf_unicol
     290    !Al1 moves this gcssold var from common fcg_gcssold to
     291    Turb_fcg_gcssold = xTurb_fcg_gcssold
     292    ! --------------------------------------------------------------------
     293    close(1)
     294    !Al1
     295    write(*, *) 'lmdz1d.def lu => unicol.def'
     296
     297    ! forcing_type defines the way the SCM is forced:
     298    !forcing_type = 0 ==> forcing_les = .TRUE.
     299    !             initial profiles from file prof.inp.001
     300    !             no forcing by LS convergence ;
     301    !             surface temperature imposed ;
     302    !             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
     303    !forcing_type = 1 ==> forcing_radconv = .TRUE.
     304    !             idem forcing_type = 0, but the imposed radiative cooling
     305    !             is set to 0 (hence, if iflag_radia=0 in physiq.def,
     306    !             then there is no radiative cooling at all)
     307    !forcing_type = 2 ==> forcing_toga = .TRUE.
     308    !             initial profiles from TOGA-COARE IFA files
     309    !             LS convergence and SST imposed from TOGA-COARE IFA files
     310    !forcing_type = 3 ==> forcing_GCM2SCM = .TRUE.
     311    !             initial profiles from the GCM output
     312    !             LS convergence imposed from the GCM output
     313    !forcing_type = 4 ==> forcing_twpice = .TRUE.
     314    !             initial profiles from TWP-ICE cdf file
     315    !             LS convergence, omega and SST imposed from TWP-ICE files
     316    !forcing_type = 5 ==> forcing_rico = .TRUE.
     317    !             initial profiles from RICO files
     318    !             LS convergence imposed from RICO files
     319    !forcing_type = 6 ==> forcing_amma = .TRUE.
     320    !             initial profiles from AMMA nc file
     321    !             LS convergence, omega and surface fluxes imposed from AMMA file
     322    !forcing_type = 7 ==> forcing_dice = .TRUE.
     323    !             initial profiles and large scale forcings in dice_driver.nc
     324    !             Different stages: soil model alone, atm. model alone
     325    !             then both models coupled
     326    !forcing_type = 8 ==> forcing_gabls4 = .TRUE.
     327    !             initial profiles and large scale forcings in gabls4_driver.nc
     328    !forcing_type >= 100 ==> forcing_case = .TRUE.
     329    !             initial profiles and large scale forcings in cas.nc
     330    !             LS convergence, omega and SST imposed from CINDY-DYNAMO files
     331    !             101=cindynamo
     332    !             102=bomex
     333    !forcing_type >= 100 ==> forcing_case2 = .TRUE.
     334    !             temporary flag while all the 1D cases are not whith the same cas.nc forcing file
     335    !             103=arm_cu2 ie arm_cu with new forcing format
     336    !             104=rico2 ie rico with new forcing format
     337    !forcing_type = 40 ==> forcing_GCSSold = .TRUE.
     338    !             initial profile from GCSS file
     339    !             LS convergence imposed from GCSS file
     340    !forcing_type = 50 ==> forcing_fire = .TRUE.
     341    !             forcing from fire.nc
     342    !forcing_type = 59 ==> forcing_sandu = .TRUE.
     343    !             initial profiles from sanduref file: see prof.inp.001
     344    !             SST varying with time and divergence constante: see ifa_sanduref.txt file
     345    !             Radiation has to be computed interactively
     346    !forcing_type = 60 ==> forcing_astex = .TRUE.
     347    !             initial profiles from file: see prof.inp.001
     348    !             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
     349    !             Radiation has to be computed interactively
     350    !forcing_type = 61 ==> forcing_armcu = .TRUE.
     351    !             initial profiles from file: see prof.inp.001
     352    !             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
     353    !             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
     354    !             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s
     355    !             Radiation to be switched off
     356
     357    if (forcing_type <=0) THEN
     358      forcing_les = .TRUE.
     359    elseif (forcing_type ==1) THEN
     360      forcing_radconv = .TRUE.
     361    elseif (forcing_type ==2) THEN
     362      forcing_toga = .TRUE.
     363    elseif (forcing_type ==3) THEN
     364      forcing_GCM2SCM = .TRUE.
     365    elseif (forcing_type ==4) THEN
     366      forcing_twpice = .TRUE.
     367    elseif (forcing_type ==5) THEN
     368      forcing_rico = .TRUE.
     369    elseif (forcing_type ==6) THEN
     370      forcing_amma = .TRUE.
     371    elseif (forcing_type ==7) THEN
     372      forcing_dice = .TRUE.
     373    elseif (forcing_type ==8) THEN
     374      forcing_gabls4 = .TRUE.
     375    elseif (forcing_type ==101) THEN ! Cindynamo starts 1-10-2011 0h
     376      forcing_case = .TRUE.
     377      year_ini_cas = 2011
     378      mth_ini_cas = 10
     379      day_deb = 1
     380      heure_ini_cas = 0.
     381      pdt_cas = 3 * 3600.         ! forcing frequency
     382    elseif (forcing_type ==102) THEN ! Bomex starts 24-6-1969 0h
     383      forcing_case = .TRUE.
     384      year_ini_cas = 1969
     385      mth_ini_cas = 6
     386      day_deb = 24
     387      heure_ini_cas = 0.
     388      pdt_cas = 1800.         ! forcing frequency
     389    elseif (forcing_type ==103) THEN ! Arm_cu starts 21-6-1997 11h30
     390      forcing_case2 = .TRUE.
     391      year_ini_cas = 1997
     392      mth_ini_cas = 6
     393      day_deb = 21
     394      heure_ini_cas = 11.5
     395      pdt_cas = 1800.         ! forcing frequency
     396    elseif (forcing_type ==104) THEN ! rico starts 16-12-2004 0h
     397      forcing_case2 = .TRUE.
     398      year_ini_cas = 2004
     399      mth_ini_cas = 12
     400      day_deb = 16
     401      heure_ini_cas = 0.
     402      pdt_cas = 1800.         ! forcing frequency
     403    elseif (forcing_type ==105) THEN ! bomex starts 16-12-2004 0h
     404      forcing_case2 = .TRUE.
     405      year_ini_cas = 1969
     406      mth_ini_cas = 6
     407      day_deb = 24
     408      heure_ini_cas = 0.
     409      pdt_cas = 1800.         ! forcing frequency
     410    elseif (forcing_type ==106) THEN ! ayotte_24SC starts 6-11-1992 0h
     411      forcing_case2 = .TRUE.
     412      year_ini_cas = 1992
     413      mth_ini_cas = 11
     414      day_deb = 6
     415      heure_ini_cas = 10.
     416      pdt_cas = 86400.        ! forcing frequency
     417    elseif (forcing_type ==113) THEN ! Arm_cu starts 21-6-1997 11h30
     418      forcing_SCM = .TRUE.
     419      year_ini_cas = 1997
     420      ! It is possible that those parameters are run twice.
     421      CALL getin('anneeref', year_ini_cas)
     422      CALL getin('dayref', day_deb)
     423      mth_ini_cas = 1 ! pour le moment on compte depuis le debut de l'annee
     424      CALL getin('time_ini', heure_ini_cas)
     425    elseif (forcing_type ==40) THEN
     426      forcing_GCSSold = .TRUE.
     427    elseif (forcing_type ==50) THEN
     428      forcing_fire = .TRUE.
     429    elseif (forcing_type ==59) THEN
     430      forcing_sandu = .TRUE.
     431    elseif (forcing_type ==60) THEN
     432      forcing_astex = .TRUE.
     433    elseif (forcing_type ==61) THEN
     434      forcing_armcu = .TRUE.
     435      IF(llm/=19.AND.llm/=40) stop 'Erreur nombre de niveaux !!'
     436    else
     437      write (*, *) 'ERROR : unknown forcing_type ', forcing_type
     438      stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'
     439    ENDIF
     440    PRINT*, "forcing type=", forcing_type
     441
     442    ! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time
     443    ! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature
     444    ! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F
     445    ! through the common sst_forcing.
     446
     447    type_ts_forcing = 0
     448    if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice)                 &
     449            type_ts_forcing = 1
     450
     451    ! Initialization of the logical switch for nudging
     452    jcode = iflag_nudge
     453    do i = 1, nudge_max
     454      nudge(i) = mod(jcode, 10) >= 1
     455      jcode = jcode / 10
    710456    enddo
    711     write(*, *) '***********************'
    712   ENDIF
    713 
    714   !=====================================================================
    715   ! EVENTUALLY, READ FORCING DATA :
    716   !=====================================================================
    717 
    718   INCLUDE "old_1D_read_forc_cases.h"
    719 
    720 IF (forcing_GCM2SCM) then
     457    !---------------------------------------------------------------------
     458    !  Definition of the run
     459    !---------------------------------------------------------------------
     460
     461    CALL conf_gcm(99, .TRUE.)
     462
     463    !-----------------------------------------------------------------------
     464    allocate(phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
     465    phy_nat(:) = 0.0
     466    allocate(phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
     467    allocate(phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
     468    allocate(phy_bil (year_len))  ! Ne sert que pour les slab_ocean
     469    phy_bil(:) = 1.0
     470    allocate(phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
     471    allocate(phy_ice (year_len)) ! Fraction de glace
     472    phy_ice(:) = 0.0
     473    allocate(phy_fter(year_len)) ! Fraction de terre
     474    phy_fter(:) = 0.0
     475    allocate(phy_foce(year_len)) ! Fraction de ocean
     476    phy_foce(:) = 0.0
     477    allocate(phy_fsic(year_len)) ! Fraction de glace
     478    phy_fsic(:) = 0.0
     479    allocate(phy_flic(year_len)) ! Fraction de glace
     480    phy_flic(:) = 0.0
     481    !-----------------------------------------------------------------------
     482    !   Choix du calendrier
     483    !   -------------------
     484
     485    !      calend = 'earth_365d'
     486    if (calend == 'earth_360d') then
     487      CALL ioconf_calendar('360_day')
     488      write(*, *)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
     489    else if (calend == 'earth_365d') then
     490      CALL ioconf_calendar('noleap')
     491      write(*, *)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
     492    else if (calend == 'earth_366d') then
     493      CALL ioconf_calendar('all_leap')
     494      write(*, *)'CALENDRIER CHOISI: Terrestre bissextile'
     495    else if (calend == 'gregorian') then
     496      stop 'gregorian calend should not be used by normal user'
     497      CALL ioconf_calendar('gregorian') ! not to be used by normal users
     498      write(*, *)'CALENDRIER CHOISI: Gregorien'
     499    else
     500      write (*, *) 'ERROR : unknown calendar ', calend
     501      stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
     502    endif
     503    !-----------------------------------------------------------------------
     504
     505    !c Date :
     506    !      La date est supposee donnee sous la forme [annee, numero du jour dans
     507    !      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
     508    !      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
     509    !      Le numero du jour est dans "day". L heure est traitee separement.
     510    !      La date complete est dans "daytime" (l'unite est le jour).
     511    if (nday>0) then
     512      fnday = nday
     513    else
     514      fnday = -nday / float(day_step)
     515    endif
     516    print *, 'fnday=', fnday
     517    !     start_time doit etre en FRACTION DE JOUR
     518    start_time = time_ini / 24.
     519
     520    ! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
     521    IF(forcing_type == 61) fnday = 53100. / 86400.
     522    IF(forcing_type == 103) fnday = 53100. / 86400.
     523    ! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)
     524    IF(forcing_type == 6) fnday = 64800. / 86400.
     525    !     IF(forcing_type .EQ. 6) fnday=50400./86400.
     526    IF(forcing_type == 8) fnday = 129600. / 86400.
     527    annee_ref = anneeref
     528    mois = 1
     529    day_ref = dayref
     530    heure = 0.
     531    itau_dyn = 0
     532    itau_phy = 0
     533    CALL ymds2ju(annee_ref, mois, day_ref, heure, day)
     534    day_ini = int(day)
     535    day_end = day_ini + int(fnday)
     536
     537    IF (forcing_type ==2) THEN
     538      ! Convert the initial date of Toga-Coare to Julian day
     539      CALL ymds2ju                                                          &
     540              (year_ini_toga, mth_ini_toga, day_ini_toga, heure, day_ju_ini_toga)
     541
     542    ELSEIF (forcing_type ==4) THEN
     543      ! Convert the initial date of TWPICE to Julian day
     544      CALL ymds2ju                                                          &
     545              (year_ini_twpi, mth_ini_twpi, day_ini_twpi, heure_ini_twpi              &
     546              , day_ju_ini_twpi)
     547    ELSEIF (forcing_type ==6) THEN
     548      ! Convert the initial date of AMMA to Julian day
     549      CALL ymds2ju                                                          &
     550              (year_ini_amma, mth_ini_amma, day_ini_amma, heure_ini_amma              &
     551              , day_ju_ini_amma)
     552    ELSEIF (forcing_type ==7) THEN
     553      ! Convert the initial date of DICE to Julian day
     554      CALL ymds2ju                                                         &
     555              (year_ini_dice, mth_ini_dice, day_ini_dice, heure_ini_dice             &
     556              , day_ju_ini_dice)
     557    ELSEIF (forcing_type ==8) THEN
     558      ! Convert the initial date of GABLS4 to Julian day
     559      CALL ymds2ju                                                         &
     560              (year_ini_gabls4, mth_ini_gabls4, day_ini_gabls4, heure_ini_gabls4     &
     561              , day_ju_ini_gabls4)
     562    ELSEIF (forcing_type >100) THEN
     563      ! Convert the initial date to Julian day
     564      day_ini_cas = day_deb
     565      PRINT*, 'time case', year_ini_cas, mth_ini_cas, day_ini_cas
     566      CALL ymds2ju                                                         &
     567              (year_ini_cas, mth_ini_cas, day_ini_cas, heure_ini_cas * 3600            &
     568              , day_ju_ini_cas)
     569      PRINT*, 'time case 2', day_ini_cas, day_ju_ini_cas
     570    ELSEIF (forcing_type ==59) THEN
     571      ! Convert the initial date of Sandu case to Julian day
     572      CALL ymds2ju                                                          &
     573              (year_ini_sandu, mth_ini_sandu, day_ini_sandu, &
     574              time_ini * 3600., day_ju_ini_sandu)
     575
     576    ELSEIF (forcing_type ==60) THEN
     577      ! Convert the initial date of Astex case to Julian day
     578      CALL ymds2ju                                                          &
     579              (year_ini_astex, mth_ini_astex, day_ini_astex, &
     580              time_ini * 3600., day_ju_ini_astex)
     581
     582    ELSEIF (forcing_type ==61) THEN
     583      ! Convert the initial date of Arm_cu case to Julian day
     584      CALL ymds2ju                                                          &
     585              (year_ini_armcu, mth_ini_armcu, day_ini_armcu, heure_ini_armcu          &
     586              , day_ju_ini_armcu)
     587    ENDIF
     588
     589    IF (forcing_type >100) THEN
     590      daytime = day + heure_ini_cas / 24. ! 1st day and initial time of the simulation
     591    ELSE
     592      daytime = day + time_ini / 24. ! 1st day and initial time of the simulation
     593    ENDIF
     594    ! Print out the actual date of the beginning of the simulation :
     595    CALL ju2ymds(daytime, year_print, month_print, day_print, sec_print)
     596    print *, ' Time of beginning : ', &
     597            year_print, month_print, day_print, sec_print
     598
     599    !---------------------------------------------------------------------
     600    ! Initialization of dimensions, geometry and initial state
     601    !---------------------------------------------------------------------
     602    !      CALL init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
     603    !     but we still need to initialize dimphy module (klon,klev,etc.)  here.
     604    CALL init_dimphy1D(1, llm)
     605    CALL suphel
     606    CALL init_infotrac
     607
     608    if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
     609    allocate(q(llm, nqtot)) ; q(:, :) = 0.
     610    allocate(dq(llm, nqtot))
     611    allocate(dq_dyn(llm, nqtot))
     612    allocate(d_q_adv(llm, nqtot))
     613    allocate(d_q_nudge(llm, nqtot))
     614    !      allocate(d_th_adv(llm))
     615
     616    q(:, :) = 0.
     617    dq(:, :) = 0.
     618    dq_dyn(:, :) = 0.
     619    d_q_adv(:, :) = 0.
     620    d_q_nudge(:, :) = 0.
     621
     622    !   No ozone climatology need be read in this pre-initialization
     623    !          (phys_state_var_init is called again in physiq)
     624    read_climoz = 0
     625    nsw = 6          ! EV et LF: sinon, falb_dir et falb_dif ne peuvent etre alloues
     626
     627    CALL phys_state_var_init(read_climoz)
     628
     629    if (ngrid/=klon) then
     630      PRINT*, 'stop in inifis'
     631      PRINT*, 'Probleme de dimensions :'
     632      PRINT*, 'ngrid = ', ngrid
     633      PRINT*, 'klon  = ', klon
     634      stop
     635    endif
     636    !!!=====================================================================
     637    !!! Feedback forcing values for Gateaux differentiation (al1)
     638    !!!=====================================================================
     639    !!! Surface Planck forcing bracketing CALL radiation
     640    !!      surf_Planck = 0.
     641    !!      surf_Conv   = 0.
     642    !!      write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv
     643    !!! a mettre dans le lmdz1d.def ou autre
     644    !!
     645    !!
     646    qsol = qsolinp
     647    qsurf = fq_sat(tsurf, psurf / 100.)
     648    beta_surf = 1.
     649    beta_aridity(:, :) = beta_surf
     650    day1 = day_ini
     651    time = daytime - day
     652    ts_toga(1) = tsurf ! needed by read_tsurf1d.F
     653    rho(1) = psurf / (rd * tsurf * (1. + (rv / rd - 1.) * qsurf))
     654
     655    !! mpl et jyg le 22/08/2012 :
     656    !!  pour que les cas a flux de surface imposes marchent
     657    IF(.NOT.ok_flux_surf.or.max(abs(wtsurf), abs(wqsurf))>0.) THEN
     658      fsens = -wtsurf * rcpd * rho(1)
     659      flat = -wqsurf * rlvtt * rho(1)
     660      print *, 'Flux: ok_flux wtsurf wqsurf', ok_flux_surf, wtsurf, wqsurf
     661    ENDIF
     662    PRINT*, 'Flux sol ', fsens, flat
     663    !!      ok_flux_surf=.FALSE.
     664    !!      fsens=-wtsurf*rcpd*rho(1)
     665    !!      flat=-wqsurf*rlvtt*rho(1)
     666    !!!!
     667
     668    ! Vertical discretization and pressure levels at half and mid levels:
     669
     670    pa = 5e4
     671    !!      preff= 1.01325e5
     672    preff = psurf
     673    IF (ok_old_disvert) THEN
     674      CALL disvert0(pa, preff, ap, bp, dpres, presnivs, nivsigs, nivsig)
     675      print *, 'On utilise disvert0'
     676      aps(1:llm) = 0.5 * (ap(1:llm) + ap(2:llm + 1))
     677      bps(1:llm) = 0.5 * (bp(1:llm) + bp(2:llm + 1))
     678      scaleheight = 8.
     679      pseudoalt(1:llm) = -scaleheight * log(presnivs(1:llm) / preff)
     680    ELSE
     681      CALL disvert()
     682      print *, 'On utilise disvert'
     683      !       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
     684      !       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
     685    ENDIF
     686
     687    sig_s = presnivs / preff
     688    plev = ap + bp * psurf
     689    play = 0.5 * (plev(1:llm) + plev(2:llm + 1))
     690    zlay = -rd * 300. * log(play / psurf) / rg ! moved after reading profiles
     691
     692    IF (forcing_type == 59) THEN
     693      ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
     694      write(*, *) '***********************'
     695      do l = 1, llm
     696        write(*, *) 'l,play(l),presnivs(l): ', l, play(l), presnivs(l)
     697        if (trouve_700 .and. play(l)<=70000) then
     698          llm700 = l
     699          print *, 'llm700,play=', llm700, play(l) / 100.
     700          trouve_700 = .FALSE.
     701        endif
     702      enddo
     703      write(*, *) '***********************'
     704    ENDIF
     705
     706    !=====================================================================
     707    ! EVENTUALLY, READ FORCING DATA :
     708    !=====================================================================
     709
     710    INCLUDE "old_1D_read_forc_cases.h"
     711
     712  IF (forcing_GCM2SCM) then
    721713  write (*, *) 'forcing_GCM2SCM not yet implemented'
    722714  stop 'in initialization'
    723715END IF ! forcing_GCM2SCM
    724716
    725 PRINT*, 'mxcalc=', mxcalc
    726 !     PRINT*,'zlay=',zlay(mxcalc)
     717        PRINT*, 'mxcalc=', mxcalc
     718        !     PRINT*,'zlay=',zlay(mxcalc)
    727719PRINT*, 'play=', play(mxcalc)
    728720
    729 !Al1 pour SST forced, appell?? depuis ocean_forced_noice
    730 ! EV tg instead of ts_cur
    731 
    732 tg = tsurf ! SST used in read_tsurf1d
    733 !=====================================================================
    734 ! Initialisation de la physique :
    735 !=====================================================================
    736 
    737 !  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
    738 
    739 ! day_step, iphysiq lus dans gcm.def ci-dessus
    740 ! timestep: calcule ci-dessous from rday et day_step
    741 ! ngrid=1
    742 ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
    743 ! rday: defini dans suphel.F (86400.)
    744 ! day_ini: lu dans run.def (dayref)
    745 ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
    746 ! airefi,zcufi,zcvfi initialises au debut de ce programme
    747 ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
    748 day_step = float(nsplit_phys) * day_step / float(iphysiq)
    749 write (*, *) 'Time step divided by nsplit_phys (=', nsplit_phys, ')'
    750 timestep = rday / day_step
    751 dtime_frcg = timestep
    752 
    753 zcufi = airefi
    754 zcvfi = airefi
    755 
    756 rlat_rad(1) = xlat * rpi / 180.
    757 rlon_rad(1) = xlon * rpi / 180.
    758 
    759 ! iniphysiq will CALL iniaqua who needs year_len from phys_cal_mod
    760 year_len_phys_cal_mod = year_len
    761 
    762 ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
    763 ! e.g. for cell boundaries, which are meaningless in 1D; so pad these
    764 ! with '0.' when necessary
    765 CALL iniphysiq(iim, jjm, llm, &
    766         1, comm_lmdz, &
    767         rday, day_ini, timestep, &
    768         (/rlat_rad(1), 0./), (/0./), &
    769         (/0., 0./), (/rlon_rad(1), 0./), &
    770         (/ (/airefi, 0./), (/0., 0./) /), &
    771         (/zcufi, 0., 0., 0./), &
    772         (/zcvfi, 0./), &
    773         ra, rg, rd, rcpd, 1)
    774 PRINT*, 'apres iniphysiq'
    775 
    776 ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
    777 co2_ppm = 330.0
    778 solaire = 1370.0
    779 
    780 ! Ecriture du startphy avant le premier appel a la physique.
    781 ! On le met juste avant pour avoir acces a tous les champs
    782 
    783 IF (ok_writedem) then
    784 
    785   !--------------------------------------------------------------------------
    786   ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
    787   ! need : qsol fder snow qsurf evap rugos agesno ftsoil
    788   !--------------------------------------------------------------------------
    789 
    790   type_ocean = "force"
    791   run_off_lic_0(1) = restart_runoff
    792   CALL fonte_neige_init(run_off_lic_0)
    793 
    794   fder = 0.
    795   snsrf(1, :) = snowmass ! masse de neige des sous surface
    796   print *, 'snsrf', snsrf
    797   qsurfsrf(1, :) = qsurf ! humidite de l'air des sous surface
    798   fevap = 0.
    799   z0m(1, :) = rugos     ! couverture de neige des sous surface
    800   z0h(1, :) = rugosh    ! couverture de neige des sous surface
    801   agesno = xagesno
    802   tsoil(:, :, :) = tsurf
    803   !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
    804   !       tsoil(1,1,1)=299.18
    805   !       tsoil(1,2,1)=300.08
    806   !       tsoil(1,3,1)=301.88
    807   !       tsoil(1,4,1)=305.48
    808   !       tsoil(1,5,1)=308.00
    809   !       tsoil(1,6,1)=308.00
    810   !       tsoil(1,7,1)=308.00
    811   !       tsoil(1,8,1)=308.00
    812   !       tsoil(1,9,1)=308.00
    813   !       tsoil(1,10,1)=308.00
    814   !       tsoil(1,11,1)=308.00
    815   !-----------------------------------------------------------------------
    816   CALL pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
    817 
    818   !------------------ prepare limit conditions for limit.nc -----------------
    819   !--   Ocean force
    820 
    821   PRINT*, 'avant phyredem'
    822   pctsrf(1, :) = 0.
    823   if (nat_surf==0.) then
    824     pctsrf(1, is_oce) = 1.
    825     pctsrf(1, is_ter) = 0.
    826     pctsrf(1, is_lic) = 0.
    827     pctsrf(1, is_sic) = 0.
    828   else if (nat_surf == 1) then
    829     pctsrf(1, is_oce) = 0.
    830     pctsrf(1, is_ter) = 1.
    831     pctsrf(1, is_lic) = 0.
    832     pctsrf(1, is_sic) = 0.
    833   else if (nat_surf == 2) then
    834     pctsrf(1, is_oce) = 0.
    835     pctsrf(1, is_ter) = 0.
    836     pctsrf(1, is_lic) = 1.
    837     pctsrf(1, is_sic) = 0.
    838   else if (nat_surf == 3) then
    839     pctsrf(1, is_oce) = 0.
    840     pctsrf(1, is_ter) = 0.
    841     pctsrf(1, is_lic) = 0.
    842     pctsrf(1, is_sic) = 1.
    843 
    844   end if
    845 
    846   PRINT*, 'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)', nat_surf         &
    847           , pctsrf(1, is_oce), pctsrf(1, is_ter)
    848 
    849   zmasq = pctsrf(1, is_ter) + pctsrf(1, is_lic)
    850   zpic = zpicinp
    851   ftsol = tsurf
    852   falb_dir = albedo
    853   falb_dif = albedo
    854   rugoro = rugos
    855   t_ancien(1, :) = temp(:)
    856   q_ancien(1, :) = q(:, 1)
    857   ql_ancien = 0.
    858   qs_ancien = 0.
    859   prlw_ancien = 0.
    860   prsw_ancien = 0.
    861   prw_ancien = 0.
    862   !jyg<
    863   !!        pbl_tke(:,:,:)=1.e-8
    864   pbl_tke(:, :, :) = 0.
    865   pbl_tke(:, 2, :) = 1.e-2
    866   PRINT *, ' pbl_tke dans lmdz1d '
    867   if (prt_level >= 5) then
    868     DO nsrf = 1, 4
    869       PRINT *, 'pbl_tke(1,:,', nsrf, ') ', pbl_tke(1, :, nsrf)
    870     ENDDO
    871   end if
    872 
    873   !>jyg
    874 
    875   rain_fall = 0.
    876   snow_fall = 0.
    877   solsw = 0.
    878   solswfdiff = 0.
    879   sollw = 0.
    880   sollwdown = rsigma * tsurf**4
    881   radsol = 0.
    882   rnebcon = 0.
    883   ratqs = 0.
    884   clwcon = 0.
    885   zmax0 = 0.
    886   zmea = zsurf
    887   zstd = 0.
    888   zsig = 0.
    889   zgam = 0.
    890   zval = 0.
    891   zthe = 0.
    892   sig1 = 0.
    893   w01 = 0.
    894 
    895   wake_deltaq = 0.
    896   wake_deltat = 0.
    897   wake_delta_pbl_TKE(:, :, :) = 0.
    898   delta_tsurf = 0.
    899   wake_fip = 0.
    900   wake_pe = 0.
    901   wake_s = 0.
    902   awake_s = 0.
    903   wake_dens = 0.
    904   awake_dens = 0.
    905   cv_gen = 0.
    906   wake_cstar = 0.
    907   ale_bl = 0.
    908   ale_bl_trig = 0.
    909   alp_bl = 0.
    910   IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
    911   IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
    912   entr_therm = 0.
    913   detr_therm = 0.
    914   f0 = 0.
    915   fm_therm = 0.
    916   u_ancien(1, :) = u(:)
    917   v_ancien(1, :) = v(:)
    918   rneb_ancien(1, :) = 0.
    919 
    920   u10m = 0.
    921   v10m = 0.
    922   ale_wake = 0.
    923   ale_bl_stat = 0.
    924 
    925   !------------------------------------------------------------------------
    926   ! Make file containing restart for the physics (startphy.nc)
    927 
    928   ! NB: List of the variables to be written by phyredem (via put_field):
    929   ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
    930   ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
    931   ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
    932   ! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
    933   ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
    934   ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
    935   ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
    936   ! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
    937   ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
    938 
    939   ! NB2: The content of the startphy.nc file depends on some flags defined in
    940   ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have
    941   ! to be set at some arbitratry convenient values.
    942   !------------------------------------------------------------------------
    943   !Al1 =============== restart option ==========================
    944   iflag_physiq = 0
    945   CALL getin('iflag_physiq', iflag_physiq)
    946 
    947   if (.not.restart) then
    948     iflag_pbl = 5
    949     CALL phyredem ("startphy.nc")
    950   else
    951     ! (desallocations)
    952     PRINT*, 'callin surf final'
    953     CALL pbl_surface_final(fder, snsrf, qsurfsrf, tsoil)
    954     PRINT*, 'after surf final'
    955     CALL fonte_neige_final(run_off_lic_0)
    956   endif
    957 
    958   ok_writedem = .FALSE.
    959   PRINT*, 'apres phyredem'
    960 
    961 END IF ! ok_writedem
    962 
    963 !------------------------------------------------------------------------
    964 ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
    965 ! --------------------------------------------------
    966 ! NB: List of the variables to be written in limit.nc
    967 !     (by writelim.F, SUBROUTINE of 1DUTILS.h):
    968 !        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
    969 !        phy_fter,phy_foce,phy_flic,phy_fsic)
    970 !------------------------------------------------------------------------
    971 DO i = 1, year_len
    972   phy_nat(i) = nat_surf
    973   phy_alb(i) = albedo
    974   phy_sst(i) = tsurf ! read_tsurf1d will be used instead
    975   phy_rug(i) = rugos
    976   phy_fter(i) = pctsrf(1, is_ter)
    977   phy_foce(i) = pctsrf(1, is_oce)
    978   phy_fsic(i) = pctsrf(1, is_sic)
    979   phy_flic(i) = pctsrf(1, is_lic)
    980 END DO
    981 
    982 ! fabrication de limit.nc
    983 CALL writelim (1, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
    984         phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
    985 
    986 CALL phys_state_var_end
    987 !Al1
    988 IF (restart) then
    989   PRINT*, 'CALL to restart dyn 1d'
    990   Call dyn1deta0("start1dyn.nc", plev, play, phi, phis, presnivs, &
    991           u, v, temp, q, omega2)
    992 
    993   PRINT*, 'fnday,annee_ref,day_ref,day_ini', &
    994           fnday, annee_ref, day_ref, day_ini
    995   !**      CALL ymds2ju(annee_ref,mois,day_ini,heure,day)
    996   day = day_ini
    997   day_end = day_ini + nday
    998   daytime = day + time_ini / 24. ! 1st day and initial time of the simulation
    999 
    1000   ! Print out the actual date of the beginning of the simulation :
    1001   CALL ju2ymds(daytime, an, mois, jour, heure)
    1002   print *, ' Time of beginning : y m d h', an, mois, jour, heure / 3600.
    1003 
    1004   day = int(daytime)
    1005   time = daytime - day
    1006 
    1007   PRINT*, '****** intialised fields from restart1dyn *******'
    1008   PRINT*, 'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
    1009   PRINT*, 'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
    1010   PRINT*, temp(1), q(1, 1), u(1), v(1), plev(1), phis
    1011   ! raz for safety
    1012   do l = 1, llm
    1013     dq_dyn(l, 1) = 0.
    1014   enddo
    1015 END IF
    1016 !Al1 ================  end restart =================================
    1017 IF (ecrit_slab_oc==1) then
    1018   open(97, file = 'div_slab.dat', STATUS = 'UNKNOWN')
    1019 elseif (ecrit_slab_oc==0) then
    1020   open(97, file = 'div_slab.dat', STATUS = 'OLD')
    1021 END IF
    1022 
    1023 !---------------------------------------------------------------------
    1024 !    Initialize target profile for RHT nudging if needed
    1025 !---------------------------------------------------------------------
    1026 IF (nudge(inudge_RHT)) then
    1027   CALL nudge_RHT_init(plev, play, temp, q(:, 1), t_targ, rh_targ)
    1028 END IF
    1029 IF (nudge(inudge_UV)) then
    1030   CALL nudge_UV_init(plev, play, u, v, u_targ, v_targ)
    1031 END IF
    1032 
    1033 !=====================================================================
    1034 IF (CPPKEY_OUTPUTPHYSSCM)
    1035   CALL iophys_ini(timestep)
    1036 END IF
    1037 ! START OF THE TEMPORAL LOOP :
    1038 !=====================================================================
    1039 
    1040 it_end = nint(fnday * day_step)
    1041 !test JLD     it_end = 10
    1042 DO while(it<=it_end)
    1043 
    1044   if (prt_level>=1) then
    1045     PRINT*, 'XXXXXXXXXXXXXXXXXXX ITAP,day,time=', &
    1046             it, day, time, it_end, day_step
    1047     PRINT*, 'PAS DE TEMPS ', timestep
    1048   endif
    1049   !Al1 demande de restartphy.nc
    1050   if (it==it_end) lastcall = .True.
    1051 
    1052   !---------------------------------------------------------------------
    1053   !  Geopotential :
    1054   !---------------------------------------------------------------------
    1055 
    1056   phi(1) = RD * temp(1) * (plev(1) - play(1)) / (.5 * (plev(1) + play(1)))
    1057   do l = 1, llm - 1
    1058     phi(l + 1) = phi(l) + RD * (temp(l) + temp(l + 1)) * &
    1059             (play(l) - play(l + 1)) / (play(l) + play(l + 1))
    1060   enddo
    1061 
    1062   !---------------------------------------------------------------------
    1063   ! Interpolation of forcings in time and onto model levels
    1064   !---------------------------------------------------------------------
    1065 
    1066   INCLUDE "old_1D_interp_cases.h"
    1067 
    1068 IF (forcing_GCM2SCM) then
    1069   write (*, *) 'forcing_GCM2SCM not yet implemented'
    1070   stop 'in time loop'
    1071 END IF ! forcing_GCM2SCM
    1072 
    1073 !!!!---------------------------------------------------------------------
    1074 !!!!  Geopotential :
    1075 !!!!---------------------------------------------------------------------
    1076 !!!
    1077 !!!        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
    1078 !!!        do l = 1, llm-1
    1079 !!!          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
    1080 !!!     &    (play(l)-play(l+1))/(play(l)+play(l+1))
    1081 !!!        enddo
    1082 
    1083 !---------------------------------------------------------------------
    1084 ! Listing output for debug prt_level>=1
    1085 !---------------------------------------------------------------------
    1086 IF (prt_level>=1) then
    1087   print *, ' avant physiq : -------- day time ', day, time
    1088   write(*, *) 'firstcall,lastcall,phis', &
    1089           firstcall, lastcall, phis
    1090 end if
    1091 IF (prt_level>=5) then
    1092   write(*, '(a10,2a4,4a13)') 'BEFOR1 IT=', 'it', 'l', &
    1093           'presniv', 'plev', 'play', 'phi'
    1094   write(*, '(a10,2i4,4f13.2)') ('BEFOR1 IT= ', it, l, &
    1095           presnivs(l), plev(l), play(l), phi(l), l = 1, llm)
    1096   write(*, '(a11,2a4,a11,6a8)') 'BEFOR2', 'it', 'l', &
    1097           'presniv', 'u', 'v', 'temp', 'q1', 'q2', 'omega2'
    1098   write(*, '(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ', it, l, &
    1099           presnivs(l), u(l), v(l), temp(l), q(l, 1), q(l, 2), omega2(l), l = 1, llm)
    1100 END IF
    1101 
    1102 !---------------------------------------------------------------------
    1103 !   Call physiq :
    1104 !---------------------------------------------------------------------
    1105 CALL physiq(ngrid, llm, &
     721                !Al1 pour SST forced, appell?? depuis ocean_forced_noice
     722                ! EV tg instead of ts_cur
     723
     724                tg = tsurf ! SST used in read_tsurf1d
     725                !=====================================================================
     726                ! Initialisation de la physique :
     727                !=====================================================================
     728
     729                !  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
     730
     731                ! day_step, iphysiq lus dans gcm.def ci-dessus
     732                ! timestep: calcule ci-dessous from rday et day_step
     733                ! ngrid=1
     734                ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
     735                ! rday: defini dans suphel.F (86400.)
     736                ! day_ini: lu dans run.def (dayref)
     737                ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
     738                ! airefi,zcufi,zcvfi initialises au debut de ce programme
     739                ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
     740                day_step = float(nsplit_phys) * day_step / float(iphysiq)
     741                write (*, *) 'Time step divided by nsplit_phys (=', nsplit_phys, ')'
     742        timestep = rday / day_step
     743        dtime_frcg = timestep
     744
     745        zcufi = airefi
     746                zcvfi = airefi
     747
     748                rlat_rad(1) = xlat * rpi / 180.
     749                rlon_rad(1) = xlon * rpi / 180.
     750
     751                ! iniphysiq will CALL iniaqua who needs year_len from phys_cal_mod
     752                year_len_phys_cal_mod = year_len
     753
     754                ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
     755                ! e.g. for cell boundaries, which are meaningless in 1D; so pad these
     756                ! with '0.' when necessary
     757                CALL iniphysiq(iim, jjm, llm, &
     758                1, comm_lmdz, &
     759                rday, day_ini, timestep, &
     760                (/rlat_rad(1), 0./), (/0./), &
     761                (/0., 0./), (/rlon_rad(1), 0./), &
     762                (/ (/airefi, 0./), (/0., 0./) /), &
     763                (/zcufi, 0., 0., 0./), &
     764                (/zcvfi, 0./), &
     765                ra, rg, rd, rcpd, 1)
     766                PRINT*, 'apres iniphysiq'
     767
     768                ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
     769                co2_ppm = 330.0
     770        solaire = 1370.0
     771
     772        ! Ecriture du startphy avant le premier appel a la physique.
     773        ! On le met juste avant pour avoir acces a tous les champs
     774
     775        IF (ok_writedem) then
     776
     777        !--------------------------------------------------------------------------
     778        ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
     779        ! need : qsol fder snow qsurf evap rugos agesno ftsoil
     780        !--------------------------------------------------------------------------
     781
     782        type_ocean = "force"
     783                run_off_lic_0(1) = restart_runoff
     784        CALL fonte_neige_init(run_off_lic_0)
     785
     786                fder = 0.
     787                snsrf(1, :) = snowmass ! masse de neige des sous surface
     788        print *, 'snsrf', snsrf
     789        qsurfsrf(1, :) = qsurf ! humidite de l'air des sous surface
     790        fevap = 0.
     791        z0m(1, :) = rugos     ! couverture de neige des sous surface
     792        z0h(1, :) = rugosh    ! couverture de neige des sous surface
     793        agesno = xagesno
     794        tsoil(:, :, :) = tsurf
     795        !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
     796        !       tsoil(1,1,1)=299.18
     797        !       tsoil(1,2,1)=300.08
     798        !       tsoil(1,3,1)=301.88
     799        !       tsoil(1,4,1)=305.48
     800        !       tsoil(1,5,1)=308.00
     801        !       tsoil(1,6,1)=308.00
     802                !       tsoil(1,7,1)=308.00
     803                !       tsoil(1,8,1)=308.00
     804                !       tsoil(1,9,1)=308.00
     805                !       tsoil(1,10,1)=308.00
     806                !       tsoil(1,11,1)=308.00
     807                !-----------------------------------------------------------------------
     808                CALL pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
     809
     810        !------------------ prepare limit conditions for limit.nc -----------------
     811        !--   Ocean force
     812
     813        PRINT*, 'avant phyredem'
     814        pctsrf(1, :) = 0.
     815        if (nat_surf==0.) then
     816        pctsrf(1, is_oce) = 1.
     817        pctsrf(1, is_ter) = 0.
     818        pctsrf(1, is_lic) = 0.
     819        pctsrf(1, is_sic) = 0.
     820        else if (nat_surf == 1) then
     821        pctsrf(1, is_oce) = 0.
     822        pctsrf(1, is_ter) = 1.
     823        pctsrf(1, is_lic) = 0.
     824        pctsrf(1, is_sic) = 0.
     825        else if (nat_surf == 2) then
     826        pctsrf(1, is_oce) = 0.
     827        pctsrf(1, is_ter) = 0.
     828        pctsrf(1, is_lic) = 1.
     829        pctsrf(1, is_sic) = 0.
     830        else if (nat_surf == 3) then
     831        pctsrf(1, is_oce) = 0.
     832        pctsrf(1, is_ter) = 0.
     833        pctsrf(1, is_lic) = 0.
     834        pctsrf(1, is_sic) = 1.
     835
     836        end if
     837
     838        PRINT*, 'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)', nat_surf         &
     839        , pctsrf(1, is_oce), pctsrf(1, is_ter)
     840
     841                zmasq = pctsrf(1, is_ter) + pctsrf(1, is_lic)
     842        zpic = zpicinp
     843        ftsol = tsurf
     844        falb_dir = albedo
     845        falb_dif = albedo
     846        rugoro = rugos
     847                t_ancien(1, :) = temp(:)
     848                q_ancien(1, :) = q(:, 1)
     849        ql_ancien = 0.
     850        qs_ancien = 0.
     851        prlw_ancien = 0.
     852        prsw_ancien = 0.
     853        prw_ancien = 0.
     854                !jyg<
     855                !!        pbl_tke(:,:,:)=1.e-8
     856                pbl_tke(:, :, :) = 0.
     857                pbl_tke(:, 2, :) = 1.e-2
     858                PRINT *, ' pbl_tke dans lmdz1d '
     859                if (prt_level >= 5) then
     860                DO nsrf = 1, 4
     861                PRINT *, 'pbl_tke(1,:,', nsrf, ') ', pbl_tke(1, :, nsrf)
     862        ENDDO
     863        end if
     864
     865        !>jyg
     866
     867        rain_fall = 0.
     868        snow_fall = 0.
     869        solsw = 0.
     870        solswfdiff = 0.
     871        sollw = 0.
     872        sollwdown = rsigma * tsurf**4
     873        radsol = 0.
     874        rnebcon = 0.
     875        ratqs = 0.
     876        clwcon = 0.
     877                zmax0 = 0.
     878                zmea = zsurf
     879                zstd = 0.
     880        zsig = 0.
     881        zgam = 0.
     882                zval = 0.
     883                zthe = 0.
     884                sig1 = 0.
     885        w01 = 0.
     886
     887        wake_deltaq = 0.
     888                wake_deltat = 0.
     889                wake_delta_pbl_TKE(:, :, :) = 0.
     890        delta_tsurf = 0.
     891        wake_fip = 0.
     892                wake_pe = 0.
     893                wake_s = 0.
     894                awake_s = 0.
     895                wake_dens = 0.
     896                awake_dens = 0.
     897                cv_gen = 0.
     898                wake_cstar = 0.
     899                ale_bl = 0.
     900                ale_bl_trig = 0.
     901                alp_bl = 0.
     902                IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
     903                IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
     904                entr_therm = 0.
     905                detr_therm = 0.
     906        f0 = 0.
     907        fm_therm = 0.
     908        u_ancien(1, :) = u(:)
     909                v_ancien(1, :) = v(:)
     910                rneb_ancien(1, :) = 0.
     911
     912        u10m = 0.
     913        v10m = 0.
     914                ale_wake = 0.
     915                ale_bl_stat = 0.
     916
     917                !------------------------------------------------------------------------
     918                ! Make file containing restart for the physics (startphy.nc)
     919
     920                ! NB: List of the variables to be written by phyredem (via put_field):
     921                ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
     922                ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
     923                ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
     924                ! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
     925                ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
     926                ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
     927                ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
     928                ! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
     929                ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
     930
     931                ! NB2: The content of the startphy.nc file depends on some flags defined in
     932                ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have
     933                ! to be set at some arbitratry convenient values.
     934                !------------------------------------------------------------------------
     935                !Al1 =============== restart option ==========================
     936                iflag_physiq = 0
     937                CALL getin('iflag_physiq', iflag_physiq)
     938
     939                if (.not.restart) then
     940                iflag_pbl = 5
     941                CALL phyredem ("startphy.nc")
     942        else
     943        ! (desallocations)
     944        PRINT*, 'callin surf final'
     945        CALL pbl_surface_final(fder, snsrf, qsurfsrf, tsoil)
     946                PRINT*, 'after surf final'
     947                CALL fonte_neige_final(run_off_lic_0)
     948                endif
     949
     950                ok_writedem = .FALSE.
     951                PRINT*, 'apres phyredem'
     952
     953        END IF ! ok_writedem
     954
     955        !------------------------------------------------------------------------
     956        ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
     957        ! --------------------------------------------------
     958        ! NB: List of the variables to be written in limit.nc
     959        !     (by writelim.F, SUBROUTINE of 1DUTILS.h):
     960                !        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
     961                !        phy_fter,phy_foce,phy_flic,phy_fsic)
     962                !------------------------------------------------------------------------
     963                DO i = 1, year_len
     964                phy_nat(i) = nat_surf
     965        phy_alb(i) = albedo
     966        phy_sst(i) = tsurf ! read_tsurf1d will be used instead
     967        phy_rug(i) = rugos
     968        phy_fter(i) = pctsrf(1, is_ter)
     969        phy_foce(i) = pctsrf(1, is_oce)
     970                phy_fsic(i) = pctsrf(1, is_sic)
     971                phy_flic(i) = pctsrf(1, is_lic)
     972                END DO
     973
     974                ! fabrication de limit.nc
     975                CALL writelim (1, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
     976                phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
     977
     978                CALL phys_state_var_end
     979                !Al1
     980                IF (restart) then
     981                PRINT*, 'CALL to restart dyn 1d'
     982                Call dyn1deta0("start1dyn.nc", plev, play, phi, phis, presnivs, &
     983                u, v, temp, q, omega2)
     984
     985                PRINT*, 'fnday,annee_ref,day_ref,day_ini', &
     986                fnday, annee_ref, day_ref, day_ini
     987                !**      CALL ymds2ju(annee_ref,mois,day_ini,heure,day)
     988                day = day_ini
     989                day_end = day_ini + nday
     990        daytime = day + time_ini / 24. ! 1st day and initial time of the simulation
     991
     992        ! Print out the actual date of the beginning of the simulation :
     993        CALL ju2ymds(daytime, an, mois, jour, heure)
     994                print *, ' Time of beginning : y m d h', an, mois, jour, heure / 3600.
     995
     996                day = int(daytime)
     997                time = daytime - day
     998
     999                PRINT*, '****** intialised fields from restart1dyn *******'
     1000                PRINT*, 'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
     1001                PRINT*, 'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
     1002                PRINT*, temp(1), q(1, 1), u(1), v(1), plev(1), phis
     1003        ! raz for safety
     1004        do l = 1, llm
     1005                dq_dyn(l, 1) = 0.
     1006        enddo
     1007        END IF
     1008        !Al1 ================  end restart =================================
     1009        IF (ecrit_slab_oc==1) then
     1010        open(97, file = 'div_slab.dat', STATUS = 'UNKNOWN')
     1011                elseif (ecrit_slab_oc==0) then
     1012                open(97, file = 'div_slab.dat', STATUS = 'OLD')
     1013                END IF
     1014
     1015                !---------------------------------------------------------------------
     1016                !    Initialize target profile for RHT nudging if needed
     1017                !---------------------------------------------------------------------
     1018                IF (nudge(inudge_RHT)) then
     1019        CALL nudge_RHT_init(plev, play, temp, q(:, 1), t_targ, rh_targ)
     1020                END IF
     1021                IF (nudge(inudge_UV)) then
     1022                CALL nudge_UV_init(plev, play, u, v, u_targ, v_targ)
     1023                END IF
     1024
     1025                !=====================================================================
     1026                IF (CPPKEY_OUTPUTPHYSSCM) THEN
     1027                CALL iophys_ini(timestep)
     1028        END IF
     1029        ! START OF THE TEMPORAL LOOP :
     1030        !=====================================================================
     1031
     1032        it_end = nint(fnday * day_step)
     1033                !test JLD     it_end = 10
     1034                DO while(it<=it_end)
     1035
     1036                if (prt_level>=1) then
     1037        PRINT*, 'XXXXXXXXXXXXXXXXXXX ITAP,day,time=', &
     1038        it, day, time, it_end, day_step
     1039        PRINT*, 'PAS DE TEMPS ', timestep
     1040        endif
     1041        !Al1 demande de restartphy.nc
     1042        if (it==it_end) lastcall = .True.
     1043
     1044        !---------------------------------------------------------------------
     1045        !  Geopotential :
     1046        !---------------------------------------------------------------------
     1047
     1048        phi(1) = RD * temp(1) * (plev(1) - play(1)) / (.5 * (plev(1) + play(1)))
     1049                do l = 1, llm - 1
     1050                phi(l + 1) = phi(l) + RD * (temp(l) + temp(l + 1)) * &
     1051        (play(l) - play(l + 1)) / (play(l) + play(l + 1))
     1052                enddo
     1053
     1054                !---------------------------------------------------------------------
     1055                ! Interpolation of forcings in time and onto model levels
     1056                !---------------------------------------------------------------------
     1057
     1058                INCLUDE "old_1D_interp_cases.h"
     1059
     1060                IF (forcing_GCM2SCM) then
     1061        write (*, *) 'forcing_GCM2SCM not yet implemented'
     1062        stop 'in time loop'
     1063        END IF ! forcing_GCM2SCM
     1064
     1065        !!!!---------------------------------------------------------------------
     1066        !!!!  Geopotential :
     1067                !!!!---------------------------------------------------------------------
     1068                !!!
     1069                !!!        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
     1070                !!!        do l = 1, llm-1
     1071                !!!          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
     1072                !!!     &    (play(l)-play(l+1))/(play(l)+play(l+1))
     1073                !!!        enddo
     1074
     1075                !---------------------------------------------------------------------
     1076                ! Listing output for debug prt_level>=1
     1077                !---------------------------------------------------------------------
     1078                IF (prt_level>=1) then
     1079                print *, ' avant physiq : -------- day time ', day, time
     1080                write(*, *) 'firstcall,lastcall,phis', &
     1081                firstcall, lastcall, phis
     1082                end if
     1083                IF (prt_level>=5) then
     1084        write(*, '(a10,2a4,4a13)') 'BEFOR1 IT=', 'it', 'l', &
     1085        'presniv', 'plev', 'play', 'phi'
     1086        write(*, '(a10,2i4,4f13.2)') ('BEFOR1 IT= ', it, l, &
     1087        presnivs(l), plev(l), play(l), phi(l), l = 1, llm)
     1088                write(*, '(a11,2a4,a11,6a8)') 'BEFOR2', 'it', 'l', &
     1089                'presniv', 'u', 'v', 'temp', 'q1', 'q2', 'omega2'
     1090        write(*, '(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ', it, l, &
     1091        presnivs(l), u(l), v(l), temp(l), q(l, 1), q(l, 2), omega2(l), l = 1, llm)
     1092                END IF
     1093
     1094                !---------------------------------------------------------------------
     1095                !   Call physiq :
     1096                !---------------------------------------------------------------------
     1097                CALL physiq(ngrid, llm, &
    11061098        firstcall, lastcall, timestep, &
    11071099        plev, play, phi, phis, presnivs, &
    11081100        u, v, rot, temp, q, omega2, &
    11091101        du_phys, dv_phys, dt_phys, dq, dpsrf)
    1110 firstcall = .FALSE.
    1111 
    1112 !---------------------------------------------------------------------
    1113 ! Listing output for debug
    1114 !---------------------------------------------------------------------
    1115 IF (prt_level>=5) then
    1116   write(*, '(a11,2a4,4a13)') 'AFTER1 IT=', 'it', 'l', &
    1117           'presniv', 'plev', 'play', 'phi'
    1118   write(*, '(a11,2i4,4f13.2)') ('AFTER1 it= ', it, l, &
    1119           presnivs(l), plev(l), play(l), phi(l), l = 1, llm)
    1120   write(*, '(a11,2a4,a11,6a8)') 'AFTER2', 'it', 'l', &
    1121           'presniv', 'u', 'v', 'temp', 'q1', 'q2', 'omega2'
    1122   write(*, '(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ', it, l, &
    1123           presnivs(l), u(l), v(l), temp(l), q(l, 1), q(l, 2), omega2(l), l = 1, llm)
    1124   write(*, '(a11,2a4,a11,5a8)') 'AFTER3', 'it', 'l', &
    1125           'presniv', 'du_phys', 'dv_phys', 'dt_phys', 'dq1', 'dq2'
    1126   write(*, '(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ', it, l, &
    1127           presnivs(l), 86400 * du_phys(l), 86400 * dv_phys(l), &
    1128           86400 * dt_phys(l), 86400 * dq(l, 1), dq(l, 2), l = 1, llm)
    1129   write(*, *) 'dpsrf', dpsrf
    1130 END IF
    1131 !---------------------------------------------------------------------
    1132 !   Add physical tendencies :
    1133 !---------------------------------------------------------------------
    1134 
    1135 fcoriolis = 2. * sin(rpi * xlat / 180.) * romega
    1136 IF (forcing_radconv .or. forcing_fire) then
    1137   fcoriolis = 0.0
    1138   dt_cooling = 0.0
    1139   d_t_adv = 0.0
    1140   d_q_adv = 0.0
    1141 END IF
    1142 !      PRINT*, 'calcul de fcoriolis ', fcoriolis
    1143 
    1144 IF (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
    1145         .or.forcing_amma .or. forcing_type==101) then
    1146   fcoriolis = 0.0 ; ug = 0. ; vg = 0.
    1147 END IF
    1148 
    1149 IF(forcing_rico) then
    1150   dt_cooling = 0.
    1151 END IF
    1152 
    1153 !CRio:Attention modif sp??cifique cas de Caroline
     1102                firstcall = .FALSE.
     1103
     1104                !---------------------------------------------------------------------
     1105                ! Listing output for debug
     1106                !---------------------------------------------------------------------
     1107                IF (prt_level>=5) then
     1108        write(*, '(a11,2a4,4a13)') 'AFTER1 IT=', 'it', 'l', &
     1109        'presniv', 'plev', 'play', 'phi'
     1110        write(*, '(a11,2i4,4f13.2)') ('AFTER1 it= ', it, l, &
     1111        presnivs(l), plev(l), play(l), phi(l), l = 1, llm)
     1112                write(*, '(a11,2a4,a11,6a8)') 'AFTER2', 'it', 'l', &
     1113                'presniv', 'u', 'v', 'temp', 'q1', 'q2', 'omega2'
     1114                write(*, '(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ', it, l, &
     1115                presnivs(l), u(l), v(l), temp(l), q(l, 1), q(l, 2), omega2(l), l = 1, llm)
     1116        write(*, '(a11,2a4,a11,5a8)') 'AFTER3', 'it', 'l', &
     1117        'presniv', 'du_phys', 'dv_phys', 'dt_phys', 'dq1', 'dq2'
     1118        write(*, '(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ', it, l, &
     1119        presnivs(l), 86400 * du_phys(l), 86400 * dv_phys(l), &
     1120        86400 * dt_phys(l), 86400 * dq(l, 1), dq(l, 2), l = 1, llm)
     1121                write(*, *) 'dpsrf', dpsrf
     1122                END IF
     1123                !---------------------------------------------------------------------
     1124                !   Add physical tendencies :
     1125                !---------------------------------------------------------------------
     1126
     1127                fcoriolis = 2. * sin(rpi * xlat / 180.) * romega
     1128        IF (forcing_radconv .or. forcing_fire) then
     1129        fcoriolis = 0.0
     1130        dt_cooling = 0.0
     1131                d_t_adv = 0.0
     1132                d_q_adv = 0.0
     1133                END IF
     1134                !      PRINT*, 'calcul de fcoriolis ', fcoriolis
     1135
     1136                IF (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
     1137                .or.forcing_amma .or. forcing_type==101) then
     1138                fcoriolis = 0.0 ; ug = 0. ; vg = 0.
     1139                END IF
     1140
     1141                IF(forcing_rico) then
     1142                dt_cooling = 0.
     1143                END IF
     1144
     1145                !CRio:Attention modif sp??cifique cas de Caroline
    11541146IF (forcing_type==-1) then
    1155   fcoriolis = 0.
    1156   !Nudging
    1157 
    1158   !on calcule dt_cooling
    1159   do l = 1, llm
    1160     if (play(l)>=20000.) then
    1161       dt_cooling(l) = -1.5 / 86400.
    1162     elseif ((play(l)>=10000.).and.((play(l)<20000.))) then
    1163       dt_cooling(l) = -1.5 / 86400. * (play(l) - 10000.) / (10000.) - 1. / 86400. * (20000. - play(l)) / 10000. * (temp(l) - 200.)
    1164     else
    1165       dt_cooling(l) = -1. * (temp(l) - 200.) / 86400.
    1166     endif
    1167   enddo
    1168 
    1169 END IF
    1170 !RC
    1171 IF (forcing_sandu) then
    1172   ug(1:llm) = u_mod(1:llm)
    1173   vg(1:llm) = v_mod(1:llm)
    1174 END IF
    1175 
    1176 IF (prt_level >= 5) PRINT*, 'fcoriolis, xlat,mxcalc ', &
    1177         fcoriolis, xlat, mxcalc
    1178 
    1179 !       print *,'u-ug=',u-ug
    1180 
    1181 !!!!!!!!!!!!!!!!!!!!!!!!
    1182 ! Geostrophic wind
    1183 ! Le calcul ci dessous est insuffisamment precis
    1184 !      du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
    1185 !      dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
    1186 !!!!!!!!!!!!!!!!!!!!!!!!
    1187 sfdt = sin(0.5 * fcoriolis * timestep)
    1188 cfdt = cos(0.5 * fcoriolis * timestep)
    1189 !       print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep
    1190 
    1191 du_age(1:mxcalc) = -2. * sfdt / timestep * &
     1147        fcoriolis = 0.
     1148        !Nudging
     1149
     1150        !on calcule dt_cooling
     1151        do l = 1, llm
     1152        if (play(l)>=20000.) then
     1153        dt_cooling(l) = -1.5 / 86400.
     1154        elseif ((play(l)>=10000.).and.((play(l)<20000.))) then
     1155        dt_cooling(l) = -1.5 / 86400. * (play(l) - 10000.) / (10000.) - 1. / 86400. * (20000. - play(l)) / 10000. * (temp(l) - 200.)
     1156                else
     1157                dt_cooling(l) = -1. * (temp(l) - 200.) / 86400.
     1158        endif
     1159        enddo
     1160
     1161        END IF
     1162                !RC
     1163                IF (forcing_sandu) then
     1164                ug(1:llm) = u_mod(1:llm)
     1165                vg(1:llm) = v_mod(1:llm)
     1166                END IF
     1167
     1168                IF (prt_level >= 5) PRINT*, 'fcoriolis, xlat,mxcalc ', &
     1169                fcoriolis, xlat, mxcalc
     1170
     1171                !       print *,'u-ug=',u-ug
     1172
     1173                !!!!!!!!!!!!!!!!!!!!!!!!
     1174                ! Geostrophic wind
     1175                ! Le calcul ci dessous est insuffisamment precis
     1176                !      du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
     1177                !      dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
     1178                !!!!!!!!!!!!!!!!!!!!!!!!
     1179                sfdt = sin(0.5 * fcoriolis * timestep)
     1180                cfdt = cos(0.5 * fcoriolis * timestep)
     1181        !       print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep
     1182
     1183        du_age(1:mxcalc) = -2. * sfdt / timestep * &
    11921184        (sfdt * (u(1:mxcalc) - ug(1:mxcalc)) - &
    11931185                cfdt * (v(1:mxcalc) - vg(1:mxcalc)))
    1194 !!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
    1195 
    1196 dv_age(1:mxcalc) = -2. * sfdt / timestep * &
     1186                !!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
     1187
     1188                dv_age(1:mxcalc) = -2. * sfdt / timestep * &
    11971189        (cfdt * (u(1:mxcalc) - ug(1:mxcalc)) + &
    11981190                sfdt * (v(1:mxcalc) - vg(1:mxcalc)))
    1199 !!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
    1200 
    1201 !!!!!!!!!!!!!!!!!!!!!!!!
    1202 !  Nudging
    1203 !!!!!!!!!!!!!!!!!!!!!!!!
    1204 d_t_nudge(:) = 0.
    1205 d_q_nudge(:, :) = 0.
    1206 d_u_nudge(:) = 0.
    1207 d_v_nudge(:) = 0.
    1208 IF (nudge(inudge_RHT)) then
    1209   CALL nudge_RHT(timestep, plev, play, t_targ, rh_targ, temp, q(:, 1), &
    1210           d_t_nudge, d_q_nudge(:, 1))
    1211 END IF
    1212 IF (nudge(inudge_UV)) then
    1213   CALL nudge_UV(timestep, plev, play, u_targ, v_targ, u, v, &
    1214           d_u_nudge, d_v_nudge)
    1215 END IF
    1216 
    1217 IF (forcing_fire) THEN
    1218 
    1219   !let ww=if ( alt le 1100 ) then alt*-0.00001 else 0
    1220   !let wt=if ( alt le 1100 ) then min( -3.75e-5 , -7.5e-8*alt)  else 0
    1221   !let wq=if ( alt le 1100 ) then max( 1.5e-8 , 3e-11*alt)  else 0
    1222   d_t_adv = 0.
    1223   d_q_adv = 0.
    1224   teta = temp * (pzero / play)**rkappa
    1225   d_t_adv = 0.
    1226   d_q_adv = 0.
    1227   do l = 2, llm - 1
    1228     if (zlay(l)<=1100) then
    1229       wwww = -0.00001 * zlay(l)
    1230       d_t_adv(l) = -wwww * (teta(l) - teta(l + 1)) / (zlay(l) - zlay(l + 1)) / (pzero / play(l))**rkappa
    1231       d_q_adv(l, 1:2) = -wwww * (q(l, 1:2) - q(l + 1, 1:2)) / (zlay(l) - zlay(l + 1))
    1232       d_t_adv(l) = d_t_adv(l) + min(-3.75e-5, -7.5e-8 * zlay(l))
    1233       d_q_adv(l, 1) = d_q_adv(l, 1) + max(1.5e-8, 3e-11 * zlay(l))
    1234     endif
    1235   enddo
    1236 
    1237 END IF
    1238 
    1239 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1240 !         call  writefield_phy('dv_age' ,dv_age,llm)
     1191                !!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
     1192
     1193                !!!!!!!!!!!!!!!!!!!!!!!!
     1194                !  Nudging
     1195                !!!!!!!!!!!!!!!!!!!!!!!!
     1196                d_t_nudge(:) = 0.
     1197        d_q_nudge(:, :) = 0.
     1198        d_u_nudge(:) = 0.
     1199        d_v_nudge(:) = 0.
     1200        IF (nudge(inudge_RHT)) then
     1201        CALL nudge_RHT(timestep, plev, play, t_targ, rh_targ, temp, q(:, 1), &
     1202        d_t_nudge, d_q_nudge(:, 1))
     1203        END IF
     1204        IF (nudge(inudge_UV)) then
     1205        CALL nudge_UV(timestep, plev, play, u_targ, v_targ, u, v, &
     1206        d_u_nudge, d_v_nudge)
     1207                END IF
     1208
     1209                IF (forcing_fire) THEN
     1210
     1211        !let ww=if ( alt le 1100 ) then alt*-0.00001 else 0
     1212        !let wt=if ( alt le 1100 ) then min( -3.75e-5 , -7.5e-8*alt)  else 0
     1213        !let wq=if ( alt le 1100 ) then max( 1.5e-8 , 3e-11*alt)  else 0
     1214        d_t_adv = 0.
     1215        d_q_adv = 0.
     1216        teta = temp * (pzero / play)**rkappa
     1217        d_t_adv = 0.
     1218        d_q_adv = 0.
     1219        do l = 2, llm - 1
     1220        if (zlay(l)<=1100) then
     1221        wwww = -0.00001 * zlay(l)
     1222                d_t_adv(l) = -wwww * (teta(l) - teta(l + 1)) / (zlay(l) - zlay(l + 1)) / (pzero / play(l))**rkappa
     1223        d_q_adv(l, 1:2) = -wwww * (q(l, 1:2) - q(l + 1, 1:2)) / (zlay(l) - zlay(l + 1))
     1224                d_t_adv(l) = d_t_adv(l) + min(-3.75e-5, -7.5e-8 * zlay(l))
     1225                d_q_adv(l, 1) = d_q_adv(l, 1) + max(1.5e-8, 3e-11 * zlay(l))
     1226        endif
     1227        enddo
     1228
     1229        END IF
     1230
     1231        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1232        !         call  writefield_phy('dv_age' ,dv_age,llm)
    12411233!         call  writefield_phy('du_age' ,du_age,llm)
    1242 !         call  writefield_phy('du_phys' ,du_phys,llm)
    1243 !         call  writefield_phy('u_tend' ,u,llm)
    1244 !         call  writefield_phy('u_g' ,ug,llm)
    1245 
    1246 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1247 !! Increment state variables
    1248 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    1249 IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
    1250 
    1251   ! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h
    1252   ! au dessus de 700hpa, on relaxe vers les profils initiaux
    1253   if (forcing_sandu .OR. forcing_astex) then
    1254     INCLUDE "1D_nudge_sandu_astex.h"
    1255   else
    1256     u(1:mxcalc) = u(1:mxcalc) + timestep * (&
    1257             du_phys(1:mxcalc)                                       &
    1258                     + du_age(1:mxcalc) + du_adv(1:mxcalc)                       &
    1259                     + d_u_nudge(1:mxcalc))
    1260     v(1:mxcalc) = v(1:mxcalc) + timestep * (&
    1261             dv_phys(1:mxcalc)                                       &
    1262                     + dv_age(1:mxcalc) + dv_adv(1:mxcalc)                       &
    1263                     + d_v_nudge(1:mxcalc))
    1264     q(1:mxcalc, :) = q(1:mxcalc, :) + timestep * (&
    1265             dq(1:mxcalc, :)                                        &
    1266                     + d_q_adv(1:mxcalc, :)                                   &
    1267                     + d_q_nudge(1:mxcalc, :))
    1268 
    1269     if (prt_level>=3) then
    1270       print *, &
    1271               'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ', &
    1272               temp(1), dt_phys(1), d_t_adv(1), dt_cooling(1)
    1273       PRINT*, 'dv_phys=', dv_phys
    1274       PRINT*, 'dv_age=', dv_age
    1275       PRINT*, 'dv_adv=', dv_adv
    1276       PRINT*, 'd_v_nudge=', d_v_nudge
    1277       PRINT*, v
    1278       PRINT*, vg
    1279     endif
    1280 
    1281     temp(1:mxcalc) = temp(1:mxcalc) + timestep * (&
    1282             dt_phys(1:mxcalc)                                       &
    1283                     + d_t_adv(1:mxcalc)                                      &
    1284                     + d_t_nudge(1:mxcalc)                                      &
    1285                     + dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
    1286 
    1287     IF (CPPKEY_OUTPUTPHYSSCM)
    1288       CALL iophys_ecrit('d_t_adv', klev, 'd_t_adv', 'm/s', d_t_adv)
    1289       CALL iophys_ecrit('d_t_nudge', klev, 'd_t_nudge', 'm/s', d_t_nudge)
    1290     END IF
    1291 
    1292   endif  ! forcing_sandu or forcing_astex
    1293 
    1294   teta = temp * (pzero / play)**rkappa
    1295 
    1296   !---------------------------------------------------------------------
    1297   !   Nudge soil temperature if requested
    1298   !---------------------------------------------------------------------
    1299 
    1300   IF (nudge_tsoil .AND. .NOT. lastcall) THEN
    1301     ftsoil(1, isoil_nudge, :) = ftsoil(1, isoil_nudge, :)                     &
    1302             - timestep / tau_soil_nudge * (ftsoil(1, isoil_nudge, :) - Tsoil_nudge)
    1303   ENDIF
    1304 
    1305   !---------------------------------------------------------------------
    1306   !   Add large-scale tendencies (advection, etc) :
    1307   !---------------------------------------------------------------------
    1308 
    1309   !cc nrlmd
    1310   !cc        tmpvar=teta
    1311   !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
    1312   !cc
    1313   !cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
    1314   !cc        tmpvar(:)=q(:,1)
    1315   !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
    1316   !cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
    1317   !cc        tmpvar(:)=q(:,2)
    1318   !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
    1319   !cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
    1320 
    1321 END IF ! end if tendency of tendency should be added
    1322 
    1323 !---------------------------------------------------------------------
    1324 !   Air temperature :
    1325 !---------------------------------------------------------------------       
    1326 IF (lastcall) then
    1327   PRINT*, 'Pas de temps final ', it
    1328   CALL ju2ymds(daytime, an, mois, jour, heure)
    1329   PRINT*, 'a la date : a m j h', an, mois, jour, heure / 3600.
    1330 END IF
    1331 
    1332 !  incremente day time
    1333 !        PRINT*,'daytime bef',daytime,1./day_step
    1334 daytime = daytime + 1. / day_step
    1335 !Al1dbg
    1336 day = int(daytime + 0.1 / day_step)
    1337 !        time = max(daytime-day,0.0)
    1338 !Al1&jyg: correction de bug
    1339 !cc        time = real(mod(it,day_step))/day_step
    1340 time = time_ini / 24. + real(mod(it, day_step)) / day_step
    1341 !        PRINT*,'daytime nxt time',daytime,time
    1342 it = it + 1
    1343 
    1344 END DO
    1345 
    1346 !Al1
    1347 IF (ecrit_slab_oc/=-1) close(97)
    1348 
    1349 !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
    1350 ! -------------------------------------
    1351 CALL dyn1dredem("restart1dyn.nc", &
    1352         plev, play, phi, phis, presnivs, &
    1353         u, v, temp, q, omega2)
    1354 
    1355 CALL abort_gcm ('lmdz1d   ', 'The End  ', 0)
    1356 
    1357 END SUBROUTINE old_lmdz1d
    1358 
    1359         INCLUDE "old_1DUTILS_read_interp.h"
     1234        !         call  writefield_phy('du_phys' ,du_phys,llm)
     1235        !         call  writefield_phy('u_tend' ,u,llm)
     1236        !         call  writefield_phy('u_g' ,ug,llm)
     1237
     1238        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1239        !! Increment state variables
     1240        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1241        IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
     1242
     1243        ! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h
     1244        ! au dessus de 700hpa, on relaxe vers les profils initiaux
     1245        if (forcing_sandu .OR. forcing_astex) then
     1246        INCLUDE "1D_nudge_sandu_astex.h"
     1247        else
     1248        u(1:mxcalc) = u(1:mxcalc) + timestep * (&
     1249        du_phys(1:mxcalc)                                       &
     1250        + du_age(1:mxcalc) + du_adv(1:mxcalc)                       &
     1251        + d_u_nudge(1:mxcalc))
     1252                v(1:mxcalc) = v(1:mxcalc) + timestep * (&
     1253                dv_phys(1:mxcalc)                                       &
     1254                + dv_age(1:mxcalc) + dv_adv(1:mxcalc)                       &
     1255                + d_v_nudge(1:mxcalc))
     1256                        q(1:mxcalc, :) = q(1:mxcalc, :) + timestep * (&
     1257        dq(1:mxcalc, :)                                        &
     1258        + d_q_adv(1:mxcalc, :)                                   &
     1259        + d_q_nudge(1:mxcalc, :))
     1260
     1261                if (prt_level>=3) then
     1262                print *, &
     1263                'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ', &
     1264                temp(1), dt_phys(1), d_t_adv(1), dt_cooling(1)
     1265                PRINT*, 'dv_phys=', dv_phys
     1266                PRINT*, 'dv_age=', dv_age
     1267                PRINT*, 'dv_adv=', dv_adv
     1268                PRINT*, 'd_v_nudge=', d_v_nudge
     1269                PRINT*, v
     1270                PRINT*, vg
     1271                endif
     1272
     1273                temp(1:mxcalc) = temp(1:mxcalc) + timestep * (&
     1274        dt_phys(1:mxcalc)                                       &
     1275        + d_t_adv(1:mxcalc)                                      &
     1276        + d_t_nudge(1:mxcalc)                                      &
     1277        + dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
     1278
     1279        IF (CPPKEY_OUTPUTPHYSSCM) THEN
     1280        CALL iophys_ecrit('d_t_adv', klev, 'd_t_adv', 'm/s', d_t_adv)
     1281                CALL iophys_ecrit('d_t_nudge', klev, 'd_t_nudge', 'm/s', d_t_nudge)
     1282                END IF
     1283
     1284                endif  ! forcing_sandu or forcing_astex
     1285
     1286                teta = temp * (pzero / play)**rkappa
     1287
     1288        !---------------------------------------------------------------------
     1289        !   Nudge soil temperature if requested
     1290        !---------------------------------------------------------------------
     1291
     1292        IF (nudge_tsoil .AND. .NOT. lastcall) THEN
     1293        ftsoil(1, isoil_nudge, :) = ftsoil(1, isoil_nudge, :)                     &
     1294        - timestep / tau_soil_nudge * (ftsoil(1, isoil_nudge, :) - Tsoil_nudge)
     1295                ENDIF
     1296
     1297                !---------------------------------------------------------------------
     1298                !   Add large-scale tendencies (advection, etc) :
     1299                !---------------------------------------------------------------------
     1300
     1301                !cc nrlmd
     1302                !cc        tmpvar=teta
     1303                !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
     1304                !cc
     1305                !cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
     1306                !cc        tmpvar(:)=q(:,1)
     1307                !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
     1308                !cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
     1309                !cc        tmpvar(:)=q(:,2)
     1310                !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
     1311                !cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
     1312
     1313                END IF ! end if tendency of tendency should be added
     1314
     1315                !---------------------------------------------------------------------
     1316                !   Air temperature :
     1317                !---------------------------------------------------------------------
     1318                IF (lastcall) then
     1319                PRINT*, 'Pas de temps final ', it
     1320                CALL ju2ymds(daytime, an, mois, jour, heure)
     1321                        PRINT*, 'a la date : a m j h', an, mois, jour, heure / 3600.
     1322                END IF
     1323
     1324                !  incremente day time
     1325                        !        PRINT*,'daytime bef',daytime,1./day_step
     1326                        daytime = daytime + 1. / day_step
     1327                        !Al1dbg
     1328                        day = int(daytime + 0.1 / day_step)
     1329                !        time = max(daytime-day,0.0)
     1330                !Al1&jyg: correction de bug
     1331                !cc        time = real(mod(it,day_step))/day_step
     1332                time = time_ini / 24. + real(mod(it, day_step)) / day_step
     1333                !        PRINT*,'daytime nxt time',daytime,time
     1334                it = it + 1
     1335
     1336                        END DO
     1337
     1338                        !Al1
     1339                        IF (ecrit_slab_oc/=-1) close(97)
     1340
     1341                        !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
     1342                        ! -------------------------------------
     1343                        CALL dyn1dredem("restart1dyn.nc", &
     1344                plev, play, phi, phis, presnivs, &
     1345                u, v, temp, q, omega2)
     1346
     1347                CALL abort_gcm ('lmdz1d   ', 'The End  ', 0)
     1348
     1349                        END SUBROUTINE old_lmdz1d
     1350
     1351                        INCLUDE "old_1DUTILS_read_interp.h"
     1352        END MODULE lmdz_old_lmdz1d

  • LMDZ6/branches/Amaury_dev/libf/phylmd/dyn1d/lmdz_scm.F90

    r5103 r5104  
    1 SUBROUTINE scm
    2 
    3    USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin
    4    USE phys_state_var_mod, ONLY: phys_state_var_init, phys_state_var_end, &
    5        clwcon, detr_therm, &
    6        qsol, fevap, z0m, z0h, agesno, &
    7        du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
    8        falb_dir, falb_dif, &
    9        ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
    10        rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
    11        solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, rneb_ancien, &
    12        wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
    13        wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
    14        awake_dens, cv_gen, wake_cstar, &
    15        zgam, zmax0, zmea, zpic, zsig, &
    16        zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, &
    17        prlw_ancien, prsw_ancien, prw_ancien, &
    18        u10m,v10m,ale_wake,ale_bl_stat, ratqs_inter_
    19 
    20  
    21    USE dimphy
    22    USE surface_data, ONLY: type_ocean,ok_veget
    23    USE pbl_surface_mod, ONLY: ftsoil, pbl_surface_init, &
    24                                  pbl_surface_final
    25    USE fonte_neige_mod, ONLY: fonte_neige_init, fonte_neige_final
    26 
    27    USE infotrac ! new
    28    USE control_mod
    29    USE indice_sol_mod
    30    USE phyaqua_mod
    31 !  USE mod_1D_cases_read
    32    USE mod_1D_cases_read_std
    33    !USE mod_1D_amma_read
    34    USE print_control_mod, ONLY: lunout, prt_level
    35    USE iniphysiq_mod, ONLY: iniphysiq
    36    USE mod_const_mpi, ONLY: comm_lmdz
    37    USE physiq_mod, ONLY: physiq
    38    USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, &
    39                           preff, aps, bps, pseudoalt, scaleheight
    40    USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
    41                         itau_dyn, itau_phy, start_time, year_len
    42    USE phys_cal_mod, ONLY: year_len_phys_cal_mod => year_len
    43 
    44       implicit none
    45       INCLUDE "dimensions.h"
    46       INCLUDE "YOMCST.h"
    47 !!      INCLUDE "control.h"
    48       INCLUDE "clesphys.h"
    49       INCLUDE "dimsoil.h"
    50 !      INCLUDE "indicesol.h"
    51 
    52       INCLUDE "compar1d.h"
    53       INCLUDE "flux_arp.h"
    54       INCLUDE "date_cas.h"
    55       INCLUDE "tsoilnudge.h"
    56       INCLUDE "fcg_gcssold.h"
    57       INCLUDE "compbl.h"
    58 
    59 !=====================================================================
    60 ! DECLARATIONS
    61 !=====================================================================
    62 
    63 #undef OUTPUT_PHYS_SCM
    64 
    65 !---------------------------------------------------------------------
    66 !  Externals
    67 !---------------------------------------------------------------------
    68       external fq_sat
    69       real fq_sat
    70 
    71 !---------------------------------------------------------------------
    72 !  Arguments d' initialisations de la physique (USER DEFINE)
    73 !---------------------------------------------------------------------
    74 
    75       integer, parameter :: ngrid=1
    76       real :: zcufi    = 1.
    77       real :: zcvfi    = 1.
    78       real :: fnday
    79       real :: day, daytime
    80       real :: day1
    81       real :: heure
    82       integer :: jour
    83       integer :: mois
    84       integer :: an
    85  
    86 !---------------------------------------------------------------------
    87 !  Declarations related to forcing and initial profiles
    88 !---------------------------------------------------------------------
    89 
    90         integer :: kmax = llm
    91         integer llm700,nq1,nq2
    92         INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
    93         real timestep, frac
    94         real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)
    95         real  uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)
    96         real  ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)
    97         real  dqtdxls(nlev_max),dqtdyls(nlev_max)
    98         real  dqtdtls(nlev_max),thlpcar(nlev_max)
    99         real  qprof(nlev_max,nqmx)
    100 
    101 !        integer :: forcing_type
    102         logical :: forcing_les     = .FALSE.
    103         logical :: forcing_armcu   = .FALSE.
    104         logical :: forcing_rico    = .FALSE.
    105         logical :: forcing_radconv = .FALSE.
    106         logical :: forcing_toga    = .FALSE.
    107         logical :: forcing_twpice  = .FALSE.
    108         logical :: forcing_amma    = .FALSE.
    109         logical :: forcing_dice    = .FALSE.
    110         logical :: forcing_gabls4  = .FALSE.
    111 
    112         logical :: forcing_GCM2SCM = .FALSE.
    113         logical :: forcing_GCSSold = .FALSE.
    114         logical :: forcing_sandu   = .FALSE.
    115         logical :: forcing_astex   = .FALSE.
    116         logical :: forcing_fire    = .FALSE.
    117         logical :: forcing_case    = .FALSE.
    118         logical :: forcing_case2   = .FALSE.
    119         logical :: forcing_SCM   = .FALSE.
    120 
    121 !flag forcings
    122         logical :: nudge_wind=.TRUE.
    123         logical :: nudge_thermo=.FALSE.
    124         logical :: cptadvw=.TRUE.
    125 
    126 
    127 !=====================================================================
    128 ! DECLARATIONS FOR EACH CASE
    129 !=====================================================================
    130 
    131       INCLUDE "1D_decl_cases.h"
    132 
    133 !---------------------------------------------------------------------
    134 !  Declarations related to nudging
    135 !---------------------------------------------------------------------
    136      integer :: nudge_max
    137      parameter (nudge_max=9)
    138      integer :: inudge_RHT=1
    139      integer :: inudge_UV=2
    140      logical :: nudge(nudge_max)
    141      real :: t_targ(llm)
    142      real :: rh_targ(llm)
    143      real :: u_targ(llm)
    144      real :: v_targ(llm)
    145 
    146 !---------------------------------------------------------------------
    147 !  Declarations related to vertical discretization:
    148 !---------------------------------------------------------------------
    149       real :: pzero=1.e5
    150       real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)
    151       real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)
    152 
    153 !---------------------------------------------------------------------
    154 !  Declarations related to variables
    155 !---------------------------------------------------------------------
    156 
    157       real :: phi(llm)
    158       real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
    159       REAL rot(1, llm) ! relative vorticity, in s-1
    160       real :: rlat_rad(1),rlon_rad(1)
    161       real :: omega(llm),omega2(llm),rho(llm+1)
    162       real :: ug(llm),vg(llm),fcoriolis
    163       real :: sfdt, cfdt
    164       real :: du_phys(llm),dv_phys(llm),dt_phys(llm)
    165       real :: w_adv(llm),z_adv(llm)
    166       real :: d_t_vert_adv(llm),d_u_vert_adv(llm),d_v_vert_adv(llm)
    167       real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)
    168       real :: d_u_nudge(llm),d_v_nudge(llm)
    169 !      real :: d_u_adv(llm),d_v_adv(llm)
    170       real :: d_u_age(llm),d_v_age(llm)
    171       real :: alpha
    172       real :: ttt
    173 
    174       REAL, ALLOCATABLE, DIMENSION(:,:):: q
    175       REAL, ALLOCATABLE, DIMENSION(:,:):: dq
    176       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_vert_adv
    177       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
    178       REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
    179 !      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
    180 
    181 !---------------------------------------------------------------------
    182 !  Initialization of surface variables
    183 !---------------------------------------------------------------------
    184       real :: run_off_lic_0(1)
    185       real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)
    186       real :: tsoil(1,nsoilmx,nbsrf)
    187 !     real :: agesno(1,nbsrf)
    188 
    189 !---------------------------------------------------------------------
    190 !  Call to phyredem
    191 !---------------------------------------------------------------------
    192       logical :: ok_writedem =.TRUE.
    193       real :: sollw_in = 0.
    194       real :: solsw_in = 0.
    195      
    196 !---------------------------------------------------------------------
    197 !  Call to physiq
    198 !---------------------------------------------------------------------
    199       logical :: firstcall=.TRUE.
    200       logical :: lastcall=.FALSE.
    201       real :: phis(1)    = 0.0
    202       real :: dpsrf(1)
    203 
    204 !---------------------------------------------------------------------
    205 !  Initializations of boundary conditions
    206 !---------------------------------------------------------------------
    207       real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
    208       real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
    209       real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
    210       real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
    211       real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
    212       real, allocatable :: phy_ice (:) ! Fraction de glace
    213       real, allocatable :: phy_fter(:) ! Fraction de terre
    214       real, allocatable :: phy_foce(:) ! Fraction de ocean
    215       real, allocatable :: phy_fsic(:) ! Fraction de glace
    216       real, allocatable :: phy_flic(:) ! Fraction de glace
    217 
    218 !---------------------------------------------------------------------
    219 !  Fichiers et d'autres variables
    220 !---------------------------------------------------------------------
    221       integer :: k,l,i,it=1,mxcalc
    222       integer :: nsrf
    223       integer jcode
    224       INTEGER read_climoz
    225 
    226       integer :: it_end ! iteration number of the last call
    227 !Al1,plev,play,phi,phis,presnivs,
    228       integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
    229       data ecrit_slab_oc/-1/
    230 
    231 !     if flag_inhib_forcing = 0, tendencies of forcing are added
    232 !                           <> 0, tendencies of forcing are not added
    233       INTEGER :: flag_inhib_forcing = 0
    234 
    235 
    236       PRINT*,'VOUS ENTREZ DANS LE 1D FORMAT STANDARD'
    237 
    238 !=====================================================================
    239 ! INITIALIZATIONS
    240 !=====================================================================
    241       du_phys(:)=0.
    242       dv_phys(:)=0.
    243       dt_phys(:)=0.
    244       d_t_vert_adv(:)=0.
    245       d_u_vert_adv(:)=0.
    246       d_v_vert_adv(:)=0.
    247       dt_cooling(:)=0.
    248       d_t_adv(:)=0.
    249       d_t_nudge(:)=0.
    250       d_u_nudge(:)=0.
    251       d_v_nudge(:)=0.
    252       d_u_adv(:)=0.
    253       d_v_adv(:)=0.
    254       d_u_age(:)=0.
    255       d_v_age(:)=0.
    256      
    257      
    258 ! Initialization of Common turb_forcing
    259        dtime_frcg = 0.
    260        Turb_fcg_gcssold=.FALSE.
    261        hthturb_gcssold = 0.
    262        hqturb_gcssold = 0.
    263 
    264 
    265 
    266 
    267 !---------------------------------------------------------------------
    268 ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
    269 !---------------------------------------------------------------------
    270         CALL conf_unicol
    271 !Al1 moves this gcssold var from common fcg_gcssold to
    272         Turb_fcg_gcssold = xTurb_fcg_gcssold
    273 ! --------------------------------------------------------------------
    274         close(1)
    275         write(*,*) 'lmdz1d.def lu => unicol.def'
    276 
    277        forcing_SCM = .TRUE.
    278        year_ini_cas=1997
    279        ! It is possible that those parameters are run twice.
    280        ! A REVOIR : LIRE PEUT ETRE AN MOIS JOUR DIRECETEMENT
    281 
    282 
    283        CALL getin('anneeref',year_ini_cas)
    284        CALL getin('dayref',day_deb)
    285        mth_ini_cas=1 ! pour le moment on compte depuis le debut de l'annee
    286        CALL getin('time_ini',heure_ini_cas)
    287 
    288       PRINT*,'NATURE DE LA SURFACE ',nat_surf
    289 
    290 ! Initialization of the logical switch for nudging
    291 
    292      jcode = iflag_nudge
    293      do i = 1,nudge_max
    294        nudge(i) = mod(jcode,10) >= 1
    295        jcode = jcode/10
    296      enddo
    297 !-----------------------------------------------------------------------
    298 !  Definition of the run
    299 !-----------------------------------------------------------------------
    300 
    301       CALL conf_gcm( 99, .TRUE. )
    302      
    303 !-----------------------------------------------------------------------
    304       allocate( phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
    305       phy_nat(:)=0.0
    306       allocate( phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
    307       allocate( phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
    308       allocate( phy_bil (year_len))  ! Ne sert que pour les slab_ocean
    309       phy_bil(:)=1.0
    310       allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
    311       allocate( phy_ice (year_len)) ! Fraction de glace
    312       phy_ice(:)=0.0
    313       allocate( phy_fter(year_len)) ! Fraction de terre
    314       phy_fter(:)=0.0
    315       allocate( phy_foce(year_len)) ! Fraction de ocean
    316       phy_foce(:)=0.0
    317       allocate( phy_fsic(year_len)) ! Fraction de glace
    318       phy_fsic(:)=0.0
    319       allocate( phy_flic(year_len)) ! Fraction de glace
    320       phy_flic(:)=0.0
    321 
    322 
    323 !-----------------------------------------------------------------------
    324 !   Choix du calendrier
    325 !   -------------------
    326 
    327 !      calend = 'earth_365d'
    328       if (calend == 'earth_360d') then
    329         CALL ioconf_calendar('360_day')
    330         write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
    331       else if (calend == 'earth_365d') then
    332         CALL ioconf_calendar('noleap')
    333         write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
    334       else if (calend == 'earth_366d') then
    335         CALL ioconf_calendar('all_leap')
    336         write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
    337       else if (calend == 'gregorian') then
    338         stop 'gregorian calend should not be used by normal user'
    339         CALL ioconf_calendar('gregorian') ! not to be used by normal users
    340         write(*,*)'CALENDRIER CHOISI: Gregorien'
    341       else
    342         write (*,*) 'ERROR : unknown calendar ', calend
    343         stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
    344       endif
    345 !-----------------------------------------------------------------------
    346 
    347 !c Date :
    348 !      La date est supposee donnee sous la forme [annee, numero du jour dans
    349 !      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
    350 !      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
    351 !      Le numero du jour est dans "day". L heure est traitee separement.
    352 !      La date complete est dans "daytime" (l'unite est le jour).
    353 
    354 
    355       if (nday>0) then
    356          fnday=nday
    357       else
    358          fnday=-nday/float(day_step)
    359       endif
    360       print *,'fnday=',fnday
    361 !     start_time doit etre en FRACTION DE JOUR
    362       start_time=time_ini/24.
    363 
    364       annee_ref = anneeref
    365       mois = 1
    366       day_ref = dayref
    367       heure = 0.
    368       itau_dyn = 0
    369       itau_phy = 0
    370       CALL ymds2ju(annee_ref,mois,day_ref,heure,day)
    371       day_ini = int(day)
    372       day_end = day_ini + int(fnday)
    373 
    374 ! Convert the initial date to Julian day
    375       day_ini_cas=day_deb
    376       PRINT*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
    377       CALL ymds2ju                                                         &
    378    (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600            &
    379    ,day_ju_ini_cas)
    380       PRINT*,'time case 2',day_ini_cas,day_ju_ini_cas
    381       daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation
    382 
    383 ! Print out the actual date of the beginning of the simulation :
    384       CALL ju2ymds(daytime,year_print, month_print,day_print,sec_print)
    385       print *,' Time of beginning : ',                                      &
    386           year_print, month_print, day_print, sec_print
    387 
    388 !---------------------------------------------------------------------
    389 ! Initialization of dimensions, geometry and initial state
    390 !---------------------------------------------------------------------
    391 !     CALL init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
    392 !     but we still need to initialize dimphy module (klon,klev,etc.)  here.
    393       CALL init_dimphy1D(1,llm)
    394       CALL suphel
    395       CALL init_infotrac
    396 
    397       if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
    398       allocate(q(llm,nqtot)) ; q(:,:)=0.
    399       allocate(dq(llm,nqtot))
    400       allocate(d_q_vert_adv(llm,nqtot))
    401       allocate(d_q_adv(llm,nqtot))
    402       allocate(d_q_nudge(llm,nqtot))
    403 !      allocate(d_th_adv(llm))
    404 
    405       q(:,:) = 0.
    406       dq(:,:) = 0.
    407       d_q_vert_adv(:,:) = 0.
    408       d_q_adv(:,:) = 0.
    409       d_q_nudge(:,:) = 0.
    410 
    411 !   No ozone climatology need be read in this pre-initialization
    412 !          (phys_state_var_init is called again in physiq)
    413       read_climoz = 0
    414       nsw=6
    415 
    416       CALL phys_state_var_init(read_climoz)
    417 
    418       if (ngrid/=klon) then
    419          PRINT*,'stop in inifis'
    420          PRINT*,'Probleme de dimensions :'
    421          PRINT*,'ngrid = ',ngrid
    422          PRINT*,'klon  = ',klon
    423          stop
    424       endif
    425 !!!=====================================================================
    426 !!! Feedback forcing values for Gateaux differentiation (al1)
    427 !!!=====================================================================
    428 !!
    429       qsol = qsolinp
    430       qsurf = fq_sat(tsurf,psurf/100.)
    431       beta_aridity(:,:) = beta_surf
    432       day1= day_ini
    433       time=daytime-day
    434       ts_toga(1)=tsurf ! needed by read_tsurf1d.F
    435       rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf))
    436 
    437 !! mpl et jyg le 22/08/2012 :
    438 !!  pour que les cas a flux de surface imposes marchent
    439       IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
    440        fsens=-wtsurf*rcpd*rho(1)
    441        flat=-wqsurf*rlvtt*rho(1)
    442        print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
    443       ENDIF
    444       PRINT*,'Flux sol ',fsens,flat
    445 
    446 ! Vertical discretization and pressure levels at half and mid levels:
    447 
    448       pa   = 5e4
    449 !!      preff= 1.01325e5
    450       preff = psurf
    451       IF (ok_old_disvert) THEN
    452         CALL disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
    453         print *,'On utilise disvert0'
    454         aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))
    455         bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))
    456         scaleheight=8.
    457         pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)
    458       ELSE
    459         CALL disvert()
    460         print *,'On utilise disvert'
    461 !       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
    462 !       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
    463       ENDIF
    464 
    465       sig_s=presnivs/preff
    466       plev =ap+bp*psurf
    467       play = 0.5*(plev(1:llm)+plev(2:llm+1))
    468       zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles.
    469 
    470       IF (forcing_type == 59) THEN
    471 ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
    472       write(*,*) '***********************'
     1MODULE lmdz_scm
     2  ; PRIVATE
     3  PUBLIC scm
     4CONTAINS
     5  SUBROUTINE scm
     6    USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar, getin
     7    USE phys_state_var_mod, ONLY: phys_state_var_init, phys_state_var_end, &
     8            clwcon, detr_therm, &
     9            qsol, fevap, z0m, z0h, agesno, &
     10            du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
     11            falb_dir, falb_dif, &
     12            ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
     13            rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
     14            solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, rneb_ancien, &
     15            wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
     16            wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
     17            awake_dens, cv_gen, wake_cstar, &
     18            zgam, zmax0, zmea, zpic, zsig, &
     19            zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, &
     20            prlw_ancien, prsw_ancien, prw_ancien, &
     21            u10m, v10m, ale_wake, ale_bl_stat, ratqs_inter_
     22
     23    USE dimphy
     24    USE surface_data, ONLY: type_ocean, ok_veget
     25    USE pbl_surface_mod, ONLY: ftsoil, pbl_surface_init, &
     26            pbl_surface_final
     27    USE fonte_neige_mod, ONLY: fonte_neige_init, fonte_neige_final
     28
     29    USE infotrac
     30    USE control_mod
     31    USE indice_sol_mod
     32    USE phyaqua_mod
     33    USE mod_1D_cases_read_std
     34    USE print_control_mod, ONLY: lunout, prt_level
     35    USE iniphysiq_mod, ONLY: iniphysiq
     36    USE mod_const_mpi, ONLY: comm_lmdz
     37    USE physiq_mod, ONLY: physiq
     38    USE comvert_mod, ONLY: presnivs, ap, bp, dpres, nivsig, nivsigs, pa, &
     39            preff, aps, bps, pseudoalt, scaleheight
     40    USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
     41            itau_dyn, itau_phy, start_time, year_len
     42    USE phys_cal_mod, ONLY: year_len_phys_cal_mod => year_len
     43    USE lmdz_1dutils, ONLY: fq_sat, conf_unicol, dyn1deta0, dyn1dredem
     44    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
     45    END SUBROUTINE scm
     46   
     47    INCLUDE "dimensions.h"
     48    INCLUDE "YOMCST.h"
     49    INCLUDE "clesphys.h"
     50    INCLUDE "dimsoil.h"
     51    INCLUDE "compar1d.h"
     52    INCLUDE "flux_arp.h"
     53    INCLUDE "date_cas.h"
     54    INCLUDE "tsoilnudge.h"
     55    INCLUDE "fcg_gcssold.h"
     56    INCLUDE "compbl.h"
     57
     58    !=====================================================================
     59    ! DECLARATIONS
     60    !=====================================================================
     61
     62    !---------------------------------------------------------------------
     63    !  Arguments d' initialisations de la physique (USER DEFINE)
     64    !---------------------------------------------------------------------
     65
     66    integer, parameter :: ngrid = 1
     67    real :: zcufi = 1.
     68    real :: zcvfi = 1.
     69    real :: fnday
     70    real :: day, daytime
     71    real :: day1
     72    real :: heure
     73    integer :: jour
     74    integer :: mois
     75    integer :: an
     76
     77    !---------------------------------------------------------------------
     78    !  Declarations related to forcing and initial profiles
     79    !---------------------------------------------------------------------
     80
     81    integer :: kmax = llm
     82    integer llm700, nq1, nq2
     83    INTEGER, PARAMETER :: nlev_max = 1000, nqmx = 1000
     84    real timestep, frac
     85    real height(nlev_max), tttprof(nlev_max), qtprof(nlev_max)
     86    real  uprof(nlev_max), vprof(nlev_max), e12prof(nlev_max)
     87    real  ugprof(nlev_max), vgprof(nlev_max), wfls(nlev_max)
     88    real  dqtdxls(nlev_max), dqtdyls(nlev_max)
     89    real  dqtdtls(nlev_max), thlpcar(nlev_max)
     90    real  qprof(nlev_max, nqmx)
     91
     92    !        integer :: forcing_type
     93    logical :: forcing_les = .FALSE.
     94    logical :: forcing_armcu = .FALSE.
     95    logical :: forcing_rico = .FALSE.
     96    logical :: forcing_radconv = .FALSE.
     97    logical :: forcing_toga = .FALSE.
     98    logical :: forcing_twpice = .FALSE.
     99    logical :: forcing_amma = .FALSE.
     100    logical :: forcing_dice = .FALSE.
     101    logical :: forcing_gabls4 = .FALSE.
     102
     103    logical :: forcing_GCM2SCM = .FALSE.
     104    logical :: forcing_GCSSold = .FALSE.
     105    logical :: forcing_sandu = .FALSE.
     106    logical :: forcing_astex = .FALSE.
     107    logical :: forcing_fire = .FALSE.
     108    logical :: forcing_case = .FALSE.
     109    logical :: forcing_case2 = .FALSE.
     110    logical :: forcing_SCM = .FALSE.
     111
     112    !flag forcings
     113    logical :: nudge_wind = .TRUE.
     114    logical :: nudge_thermo = .FALSE.
     115    logical :: cptadvw = .TRUE.
     116
     117
     118    !=====================================================================
     119    ! DECLARATIONS FOR EACH CASE
     120    !=====================================================================
     121
     122    INCLUDE "1D_decl_cases.h"
     123
     124    !---------------------------------------------------------------------
     125    !  Declarations related to nudging
     126    !---------------------------------------------------------------------
     127    integer :: nudge_max
     128    parameter (nudge_max = 9)
     129    integer :: inudge_RHT = 1
     130    integer :: inudge_UV = 2
     131    logical :: nudge(nudge_max)
     132    real :: t_targ(llm)
     133    real :: rh_targ(llm)
     134    real :: u_targ(llm)
     135    real :: v_targ(llm)
     136
     137    !---------------------------------------------------------------------
     138    !  Declarations related to vertical discretization:
     139    !---------------------------------------------------------------------
     140    real :: pzero = 1.e5
     141    real :: play (llm), zlay (llm), sig_s(llm), plev(llm + 1)
     142    real :: playd(llm), zlayd(llm), ap_amma(llm + 1), bp_amma(llm + 1)
     143
     144    !---------------------------------------------------------------------
     145    !  Declarations related to variables
     146    !---------------------------------------------------------------------
     147
     148    real :: phi(llm)
     149    real :: teta(llm), tetal(llm), temp(llm), u(llm), v(llm), w(llm)
     150    REAL rot(1, llm) ! relative vorticity, in s-1
     151    real :: rlat_rad(1), rlon_rad(1)
     152    real :: omega(llm), omega2(llm), rho(llm + 1)
     153    real :: ug(llm), vg(llm), fcoriolis
     154    real :: sfdt, cfdt
     155    real :: du_phys(llm), dv_phys(llm), dt_phys(llm)
     156    real :: w_adv(llm), z_adv(llm)
     157    real :: d_t_vert_adv(llm), d_u_vert_adv(llm), d_v_vert_adv(llm)
     158    real :: dt_cooling(llm), d_t_adv(llm), d_t_nudge(llm)
     159    real :: d_u_nudge(llm), d_v_nudge(llm)
     160    !      real :: d_u_adv(llm),d_v_adv(llm)
     161    real :: d_u_age(llm), d_v_age(llm)
     162    real :: alpha
     163    real :: ttt
     164
     165    REAL, ALLOCATABLE, DIMENSION(:, :) :: q
     166    REAL, ALLOCATABLE, DIMENSION(:, :) :: dq
     167    REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_vert_adv
     168    REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_adv
     169    REAL, ALLOCATABLE, DIMENSION(:, :) :: d_q_nudge
     170    !      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
     171
     172    !---------------------------------------------------------------------
     173    !  Initialization of surface variables
     174    !---------------------------------------------------------------------
     175    real :: run_off_lic_0(1)
     176    real :: fder(1), snsrf(1, nbsrf), qsurfsrf(1, nbsrf)
     177    real :: tsoil(1, nsoilmx, nbsrf)
     178    !     real :: agesno(1,nbsrf)
     179
     180    !---------------------------------------------------------------------
     181    !  Call to phyredem
     182    !---------------------------------------------------------------------
     183    logical :: ok_writedem = .TRUE.
     184    real :: sollw_in = 0.
     185    real :: solsw_in = 0.
     186
     187    !---------------------------------------------------------------------
     188    !  Call to physiq
     189    !---------------------------------------------------------------------
     190    logical :: firstcall = .TRUE.
     191    logical :: lastcall = .FALSE.
     192    real :: phis(1) = 0.0
     193    real :: dpsrf(1)
     194
     195    !---------------------------------------------------------------------
     196    !  Initializations of boundary conditions
     197    !---------------------------------------------------------------------
     198    real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
     199    real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
     200    real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
     201    real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
     202    real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
     203    real, allocatable :: phy_ice (:) ! Fraction de glace
     204    real, allocatable :: phy_fter(:) ! Fraction de terre
     205    real, allocatable :: phy_foce(:) ! Fraction de ocean
     206    real, allocatable :: phy_fsic(:) ! Fraction de glace
     207    real, allocatable :: phy_flic(:) ! Fraction de glace
     208
     209    !---------------------------------------------------------------------
     210    !  Fichiers et d'autres variables
     211    !---------------------------------------------------------------------
     212    integer :: k, l, i, it = 1, mxcalc
     213    integer :: nsrf
     214    integer jcode
     215    INTEGER read_climoz
     216
     217    integer :: it_end ! iteration number of the last call
     218    !Al1,plev,play,phi,phis,presnivs,
     219    integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
     220    data ecrit_slab_oc/-1/
     221
     222    !     if flag_inhib_forcing = 0, tendencies of forcing are added
     223    !                           <> 0, tendencies of forcing are not added
     224    INTEGER :: flag_inhib_forcing = 0
     225
     226    PRINT*, 'VOUS ENTREZ DANS LE 1D FORMAT STANDARD'
     227
     228    !=====================================================================
     229    ! INITIALIZATIONS
     230    !=====================================================================
     231    du_phys(:) = 0.
     232    dv_phys(:) = 0.
     233    dt_phys(:) = 0.
     234    d_t_vert_adv(:) = 0.
     235    d_u_vert_adv(:) = 0.
     236    d_v_vert_adv(:) = 0.
     237    dt_cooling(:) = 0.
     238    d_t_adv(:) = 0.
     239    d_t_nudge(:) = 0.
     240    d_u_nudge(:) = 0.
     241    d_v_nudge(:) = 0.
     242    d_u_adv(:) = 0.
     243    d_v_adv(:) = 0.
     244    d_u_age(:) = 0.
     245    d_v_age(:) = 0.
     246
     247
     248    ! Initialization of Common turb_forcing
     249    dtime_frcg = 0.
     250    Turb_fcg_gcssold = .FALSE.
     251    hthturb_gcssold = 0.
     252    hqturb_gcssold = 0.
     253
     254
     255
     256
     257    !---------------------------------------------------------------------
     258    ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
     259    !---------------------------------------------------------------------
     260    CALL conf_unicol
     261    !Al1 moves this gcssold var from common fcg_gcssold to
     262    Turb_fcg_gcssold = xTurb_fcg_gcssold
     263    ! --------------------------------------------------------------------
     264    close(1)
     265    write(*, *) 'lmdz1d.def lu => unicol.def'
     266
     267    forcing_SCM = .TRUE.
     268    year_ini_cas = 1997
     269    ! It is possible that those parameters are run twice.
     270    ! A REVOIR : LIRE PEUT ETRE AN MOIS JOUR DIRECETEMENT
     271
     272    CALL getin('anneeref', year_ini_cas)
     273    CALL getin('dayref', day_deb)
     274    mth_ini_cas = 1 ! pour le moment on compte depuis le debut de l'annee
     275    CALL getin('time_ini', heure_ini_cas)
     276
     277    PRINT*, 'NATURE DE LA SURFACE ', nat_surf
     278
     279    ! Initialization of the logical switch for nudging
     280
     281    jcode = iflag_nudge
     282    do i = 1, nudge_max
     283      nudge(i) = mod(jcode, 10) >= 1
     284      jcode = jcode / 10
     285    enddo
     286    !-----------------------------------------------------------------------
     287    !  Definition of the run
     288    !-----------------------------------------------------------------------
     289
     290    CALL conf_gcm(99, .TRUE.)
     291
     292    !-----------------------------------------------------------------------
     293    allocate(phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
     294    phy_nat(:) = 0.0
     295    allocate(phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
     296    allocate(phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
     297    allocate(phy_bil (year_len))  ! Ne sert que pour les slab_ocean
     298    phy_bil(:) = 1.0
     299    allocate(phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
     300    allocate(phy_ice (year_len)) ! Fraction de glace
     301    phy_ice(:) = 0.0
     302    allocate(phy_fter(year_len)) ! Fraction de terre
     303    phy_fter(:) = 0.0
     304    allocate(phy_foce(year_len)) ! Fraction de ocean
     305    phy_foce(:) = 0.0
     306    allocate(phy_fsic(year_len)) ! Fraction de glace
     307    phy_fsic(:) = 0.0
     308    allocate(phy_flic(year_len)) ! Fraction de glace
     309    phy_flic(:) = 0.0
     310
     311
     312    !-----------------------------------------------------------------------
     313    !   Choix du calendrier
     314    !   -------------------
     315
     316    !      calend = 'earth_365d'
     317    if (calend == 'earth_360d') then
     318      CALL ioconf_calendar('360_day')
     319      write(*, *)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
     320    else if (calend == 'earth_365d') then
     321      CALL ioconf_calendar('noleap')
     322      write(*, *)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
     323    else if (calend == 'earth_366d') then
     324      CALL ioconf_calendar('all_leap')
     325      write(*, *)'CALENDRIER CHOISI: Terrestre bissextile'
     326    else if (calend == 'gregorian') then
     327      stop 'gregorian calend should not be used by normal user'
     328      CALL ioconf_calendar('gregorian') ! not to be used by normal users
     329      write(*, *)'CALENDRIER CHOISI: Gregorien'
     330    else
     331      write (*, *) 'ERROR : unknown calendar ', calend
     332      stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
     333    endif
     334    !-----------------------------------------------------------------------
     335
     336    !c Date :
     337    !      La date est supposee donnee sous la forme [annee, numero du jour dans
     338    !      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
     339    !      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
     340    !      Le numero du jour est dans "day". L heure est traitee separement.
     341    !      La date complete est dans "daytime" (l'unite est le jour).
     342
     343    if (nday>0) then
     344      fnday = nday
     345    else
     346      fnday = -nday / float(day_step)
     347    endif
     348    print *, 'fnday=', fnday
     349    !     start_time doit etre en FRACTION DE JOUR
     350    start_time = time_ini / 24.
     351
     352    annee_ref = anneeref
     353    mois = 1
     354    day_ref = dayref
     355    heure = 0.
     356    itau_dyn = 0
     357    itau_phy = 0
     358    CALL ymds2ju(annee_ref, mois, day_ref, heure, day)
     359    day_ini = int(day)
     360    day_end = day_ini + int(fnday)
     361
     362    ! Convert the initial date to Julian day
     363    day_ini_cas = day_deb
     364    PRINT*, 'time case', year_ini_cas, mth_ini_cas, day_ini_cas
     365    CALL ymds2ju                                                         &
     366            (year_ini_cas, mth_ini_cas, day_ini_cas, heure_ini_cas * 3600            &
     367            , day_ju_ini_cas)
     368    PRINT*, 'time case 2', day_ini_cas, day_ju_ini_cas
     369    daytime = day + heure_ini_cas / 24. ! 1st day and initial time of the simulation
     370
     371    ! Print out the actual date of the beginning of the simulation :
     372    CALL ju2ymds(daytime, year_print, month_print, day_print, sec_print)
     373    print *, ' Time of beginning : ', &
     374            year_print, month_print, day_print, sec_print
     375
     376    !---------------------------------------------------------------------
     377    ! Initialization of dimensions, geometry and initial state
     378    !---------------------------------------------------------------------
     379    !     CALL init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
     380    !     but we still need to initialize dimphy module (klon,klev,etc.)  here.
     381    CALL init_dimphy1D(1, llm)
     382    CALL suphel
     383    CALL init_infotrac
     384
     385    if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
     386    allocate(q(llm, nqtot)) ; q(:, :) = 0.
     387    allocate(dq(llm, nqtot))
     388    allocate(d_q_vert_adv(llm, nqtot))
     389    allocate(d_q_adv(llm, nqtot))
     390    allocate(d_q_nudge(llm, nqtot))
     391    !      allocate(d_th_adv(llm))
     392
     393    q(:, :) = 0.
     394    dq(:, :) = 0.
     395    d_q_vert_adv(:, :) = 0.
     396    d_q_adv(:, :) = 0.
     397    d_q_nudge(:, :) = 0.
     398
     399    !   No ozone climatology need be read in this pre-initialization
     400    !          (phys_state_var_init is called again in physiq)
     401    read_climoz = 0
     402    nsw = 6
     403
     404    CALL phys_state_var_init(read_climoz)
     405
     406    if (ngrid/=klon) then
     407      PRINT*, 'stop in inifis'
     408      PRINT*, 'Probleme de dimensions :'
     409      PRINT*, 'ngrid = ', ngrid
     410      PRINT*, 'klon  = ', klon
     411      stop
     412    endif
     413    !!!=====================================================================
     414    !!! Feedback forcing values for Gateaux differentiation (al1)
     415    !!!=====================================================================
     416    !!
     417    qsol = qsolinp
     418    qsurf = fq_sat(tsurf, psurf / 100.)
     419    beta_aridity(:, :) = beta_surf
     420    day1 = day_ini
     421    time = daytime - day
     422    ts_toga(1) = tsurf ! needed by read_tsurf1d.F
     423    rho(1) = psurf / (rd * tsurf * (1. + (rv / rd - 1.) * qsurf))
     424
     425    !! mpl et jyg le 22/08/2012 :
     426    !!  pour que les cas a flux de surface imposes marchent
     427    IF(.NOT.ok_flux_surf.or.max(abs(wtsurf), abs(wqsurf))>0.) THEN
     428      fsens = -wtsurf * rcpd * rho(1)
     429      flat = -wqsurf * rlvtt * rho(1)
     430      print *, 'Flux: ok_flux wtsurf wqsurf', ok_flux_surf, wtsurf, wqsurf
     431    ENDIF
     432    PRINT*, 'Flux sol ', fsens, flat
     433
     434    ! Vertical discretization and pressure levels at half and mid levels:
     435
     436    pa = 5e4
     437    !!      preff= 1.01325e5
     438    preff = psurf
     439    IF (ok_old_disvert) THEN
     440      CALL disvert0(pa, preff, ap, bp, dpres, presnivs, nivsigs, nivsig)
     441      print *, 'On utilise disvert0'
     442      aps(1:llm) = 0.5 * (ap(1:llm) + ap(2:llm + 1))
     443      bps(1:llm) = 0.5 * (bp(1:llm) + bp(2:llm + 1))
     444      scaleheight = 8.
     445      pseudoalt(1:llm) = -scaleheight * log(presnivs(1:llm) / preff)
     446    ELSE
     447      CALL disvert()
     448      print *, 'On utilise disvert'
     449      !       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
     450      !       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
     451    ENDIF
     452
     453    sig_s = presnivs / preff
     454    plev = ap + bp * psurf
     455    play = 0.5 * (plev(1:llm) + plev(2:llm + 1))
     456    zlay = -rd * 300. * log(play / psurf) / rg ! moved after reading profiles.
     457
     458    IF (forcing_type == 59) THEN
     459      ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
     460      write(*, *) '***********************'
    473461      do l = 1, llm
    474        write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
    475        if (trouve_700 .and. play(l)<=70000) then
    476          llm700=l
    477          print *,'llm700,play=',llm700,play(l)/100.
    478          trouve_700= .FALSE.
    479        endif
     462        write(*, *) 'l,play(l),presnivs(l): ', l, play(l), presnivs(l)
     463        if (trouve_700 .and. play(l)<=70000) then
     464          llm700 = l
     465          print *, 'llm700,play=', llm700, play(l) / 100.
     466          trouve_700 = .FALSE.
     467        endif
    480468      enddo
    481       write(*,*) '***********************'
    482       ENDIF
    483 
    484 !=====================================================================
    485 ! EVENTUALLY, READ FORCING DATA :
    486 !=====================================================================
    487 
    488       INCLUDE "1D_read_forc_cases.h"
    489    PRINT*,'A d_t_adv ',d_t_adv(1:20)*86400
    490 
    491       if (forcing_GCM2SCM) then
    492         write (*,*) 'forcing_GCM2SCM not yet implemented'
    493         stop 'in initialization'
    494       endif ! forcing_GCM2SCM
    495 
    496 
    497 !=====================================================================
    498 ! Initialisation de la physique :
    499 !=====================================================================
    500 
    501 !  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
    502 
    503 ! day_step, iphysiq lus dans gcm.def ci-dessus
    504 ! timestep: calcule ci-dessous from rday et day_step
    505 ! ngrid=1
    506 ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
    507 ! rday: defini dans suphel.F (86400.)
    508 ! day_ini: lu dans run.def (dayref)
    509 ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
    510 ! airefi,zcufi,zcvfi initialises au debut de ce programme
    511 ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
    512 
    513 
    514       day_step = float(nsplit_phys)*day_step/float(iphysiq)
    515       write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
    516       timestep =rday/day_step
    517       dtime_frcg = timestep
    518 
    519       zcufi=airefi
    520       zcvfi=airefi
    521 
    522       rlat_rad(1)=xlat*rpi/180.
    523       rlon_rad(1)=xlon*rpi/180.
    524 
    525      ! iniphysiq will CALL iniaqua who needs year_len from phys_cal_mod
    526      year_len_phys_cal_mod=year_len
    527            
    528      ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
    529      ! e.g. for cell boundaries, which are meaningless in 1D; so pad these
    530      ! with '0.' when necessary
    531 
    532       CALL iniphysiq(iim,jjm,llm, &
    533            1,comm_lmdz, &
    534            rday,day_ini,timestep, &
    535            (/rlat_rad(1),0./),(/0./), &
    536            (/0.,0./),(/rlon_rad(1),0./), &
    537            (/ (/airefi,0./),(/0.,0./) /), &
    538            (/zcufi,0.,0.,0./), &
    539            (/zcvfi,0./), &
    540            ra,rg,rd,rcpd,1)
    541       PRINT*,'apres iniphysiq'
    542 
    543 ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
    544       co2_ppm= 330.0
    545       solaire=1370.0
    546 
    547 ! Ecriture du startphy avant le premier appel a la physique.
    548 ! On le met juste avant pour avoir acces a tous les champs
    549 
    550       if (ok_writedem) then
    551 
    552 !--------------------------------------------------------------------------
    553 ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
    554 ! need : qsol fder snow qsurf evap rugos agesno ftsoil
    555 !--------------------------------------------------------------------------
    556 
    557         type_ocean = "force"
    558         run_off_lic_0(1) = restart_runoff
    559         CALL fonte_neige_init(run_off_lic_0)
    560 
    561         fder=0.
    562         snsrf(1,:)=snowmass ! masse de neige des sous surface
    563         qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
    564         fevap=0.
    565         z0m(1,:)=rugos     ! couverture de neige des sous surface
    566         z0h(1,:)=rugosh    ! couverture de neige des sous surface
    567         agesno = xagesno
    568         tsoil(:,:,:)=tsurf
    569 !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
    570 !       tsoil(1,1,1)=299.18
    571 !       tsoil(1,2,1)=300.08
    572 !       tsoil(1,3,1)=301.88
    573 !       tsoil(1,4,1)=305.48
    574 !       tsoil(1,5,1)=308.00
    575 !       tsoil(1,6,1)=308.00
    576 !       tsoil(1,7,1)=308.00
    577 !       tsoil(1,8,1)=308.00
    578 !       tsoil(1,9,1)=308.00
    579 !       tsoil(1,10,1)=308.00
    580 !       tsoil(1,11,1)=308.00
    581 !-----------------------------------------------------------------------
    582         CALL pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
    583 
    584 !------------------ prepare limit conditions for limit.nc -----------------
    585 !--   Ocean force
    586 
    587         PRINT*,'avant phyredem'
    588         pctsrf(1,:)=0.
    589           if (nat_surf==0.) then
    590           pctsrf(1,is_oce)=1.
    591           pctsrf(1,is_ter)=0.
    592           pctsrf(1,is_lic)=0.
    593           pctsrf(1,is_sic)=0.
    594         else if (nat_surf == 1) then
    595           pctsrf(1,is_oce)=0.
    596           pctsrf(1,is_ter)=1.
    597           pctsrf(1,is_lic)=0.
    598           pctsrf(1,is_sic)=0.
    599         else if (nat_surf == 2) then
    600           pctsrf(1,is_oce)=0.
    601           pctsrf(1,is_ter)=0.
    602           pctsrf(1,is_lic)=1.
    603           pctsrf(1,is_sic)=0.
    604         else if (nat_surf == 3) then
    605           pctsrf(1,is_oce)=0.
    606           pctsrf(1,is_ter)=0.
    607           pctsrf(1,is_lic)=0.
    608           pctsrf(1,is_sic)=1.
    609 
    610      end if
    611 
    612 
    613         PRINT*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf         &
    614           ,pctsrf(1,is_oce),pctsrf(1,is_ter)
    615 
    616         zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)
    617         zpic = zpicinp
    618         ftsol=tsurf
    619         falb_dir=albedo
    620         falb_dif=albedo
    621         rugoro=rugos
    622         t_ancien(1,:)=temp(:)
    623         q_ancien(1,:)=q(:,1)
    624         ql_ancien = 0.
    625         qs_ancien = 0.
    626         prlw_ancien = 0.
     469      write(*, *) '***********************'
     470    ENDIF
     471
     472    !=====================================================================
     473    ! EVENTUALLY, READ FORCING DATA :
     474    !=====================================================================
     475
     476    INCLUDE "1D_read_forc_cases.h"
     477  PRINT*, 'A d_t_adv ', d_t_adv(1:20)*86400
     478
     479  if (forcing_GCM2SCM) then
     480  write (*, *) 'forcing_GCM2SCM not yet implemented'
     481  stop 'in initialization'
     482  endif ! forcing_GCM2SCM
     483
     484
     485  !=====================================================================
     486  ! Initialisation de la physique :
     487  !=====================================================================
     488
     489  !  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
     490
     491  ! day_step, iphysiq lus dans gcm.def ci-dessus
     492  ! timestep: calcule ci-dessous from rday et day_step
     493  ! ngrid=1
     494  ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
     495  ! rday: defini dans suphel.F (86400.)
     496  ! day_ini: lu dans run.def (dayref)
     497  ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
     498  ! airefi,zcufi,zcvfi initialises au debut de ce programme
     499  ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
     500
     501
     502  day_step = float(nsplit_phys)*day_step/float(iphysiq)
     503  write (*, *) 'Time step divided by nsplit_phys (=', nsplit_phys, ')'
     504  timestep = rday/day_step
     505  dtime_frcg = timestep
     506
     507  zcufi = airefi
     508  zcvfi = airefi
     509
     510  rlat_rad(1) = xlat*rpi/180.
     511  rlon_rad(1) = xlon*rpi/180.
     512
     513  ! iniphysiq will CALL iniaqua who needs year_len from phys_cal_mod
     514  year_len_phys_cal_mod = year_len
     515
     516  ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
     517  ! e.g. for cell boundaries, which are meaningless in 1D; so pad these
     518  ! with '0.' when necessary
     519
     520  CALL iniphysiq(iim, jjm, llm, &
     521        1, comm_lmdz, &
     522        rday, day_ini, timestep, &
     523        (/rlat_rad(1), 0./), (/0./), &
     524        (/0., 0./), (/rlon_rad(1), 0./), &
     525        (/ (/airefi, 0./), (/0., 0./) /), &
     526        (/zcufi, 0., 0., 0./), &
     527        (/zcvfi, 0./), &
     528        ra, rg, rd,rcpd, 1)
     529  PRINT*, 'apres iniphysiq'
     530
     531  ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
     532  co2_ppm = 330.0
     533  solaire = 1370.0
     534
     535  ! Ecriture du startphy avant le premier appel a la physique.
     536  ! On le met juste avant pour avoir acces a tous les champs
     537
     538  if (ok_writedem) then
     539
     540  !--------------------------------------------------------------------------
     541  ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
     542  ! need : qsol fder snow qsurf evap rugos agesno ftsoil
     543  !--------------------------------------------------------------------------
     544
     545  type_ocean = "force"
     546  run_off_lic_0(1) = restart_runoff
     547  CALL fonte_neige_init(run_off_lic_0)
     548
     549  fder = 0.
     550  snsrf(1, :) = snowmass ! masse de neige des sous surface
     551  qsurfsrf(1, :) = qsurf ! humidite de l'air des sous surface
     552  fevap = 0.
     553  z0m(1, :) = rugos     ! couverture de neige des sous surface
     554  z0h(1, :) = rugosh    ! couverture de neige des sous surface
     555  agesno = xagesno
     556  tsoil(:, :, :) = tsurf
     557  !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
     558  !       tsoil(1,1,1)=299.18
     559  !       tsoil(1,2,1)=300.08
     560  !       tsoil(1,3,1)=301.88
     561  !       tsoil(1,4,1)=305.48
     562  !       tsoil(1,5,1)=308.00
     563  !       tsoil(1,6,1)=308.00
     564  !       tsoil(1,7,1)=308.00
     565  !       tsoil(1,8,1)=308.00
     566  !       tsoil(1,9,1)=308.00
     567  !       tsoil(1,10,1)=308.00
     568  !       tsoil(1,11,1)=308.00
     569  !-----------------------------------------------------------------------
     570  CALL pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
     571
     572  !------------------ prepare limit conditions for limit.nc -----------------
     573  !--   Ocean force
     574
     575  PRINT*, 'avant phyredem'
     576  pctsrf(1, :) = 0.
     577  if (nat_surf==0.) then
     578  pctsrf(1, is_oce) = 1.
     579  pctsrf(1, is_ter) = 0.
     580  pctsrf(1, is_lic) = 0.
     581  pctsrf(1, is_sic) = 0.
     582  else if (nat_surf == 1) then
     583  pctsrf(1, is_oce) = 0.
     584  pctsrf(1, is_ter) = 1.
     585  pctsrf(1, is_lic) = 0.
     586  pctsrf(1, is_sic) = 0.
     587  else if (nat_surf == 2) then
     588  pctsrf(1, is_oce) = 0.
     589  pctsrf(1, is_ter) = 0.
     590  pctsrf(1, is_lic) = 1.
     591  pctsrf(1, is_sic) = 0.
     592  else if (nat_surf == 3) then
     593  pctsrf(1, is_oce) = 0.
     594  pctsrf(1, is_ter) = 0.
     595  pctsrf(1, is_lic) = 0.
     596  pctsrf(1, is_sic) = 1.
     597
     598end if
     599
     600
     601        PRINT*, 'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)', nat_surf         &
     602        , pctsrf(1, is_oce), pctsrf(1, is_ter)
     603
     604                zmasq = pctsrf(1, is_ter)+pctsrf(1, is_lic)
     605                zpic = zpicinp
     606                ftsol = tsurf
     607                falb_dir= albedo
     608                falb_dif = albedo
     609                rugoro = rugos
     610        t_ancien(1, :)= temp(:)
     611                q_ancien(1, :)= q(:, 1)
     612                ql_ancien = 0.
     613                qs_ancien = 0.
     614                prlw_ancien = 0.
    627615        prsw_ancien = 0.
    628616        prw_ancien = 0.
    629 !jyg<
    630 ! Etienne: comment those lines since now the TKE is inialized in 1D_read_forc_cases
    631 !!      pbl_tke(:,:,:)=1.e-8
    632 !        pbl_tke(:,:,:)=0.
    633 !        pbl_tke(:,2,:)=1.e-2
    634 !>jyg
    635         rain_fall=0.
    636         snow_fall=0.
    637         solsw=0.
    638         solswfdiff=0.
    639         sollw=0.
    640         sollwdown=rsigma*tsurf**4
    641         radsol=0.
    642         rnebcon=0.
    643         ratqs=0.
    644         clwcon=0.
    645         zmax0 = 0.
    646         zmea=zsurf
    647         zstd=0.
    648         zsig=0.
    649         zgam=0.
    650         zval=0.
    651         zthe=0.
    652         sig1=0.
    653         w01=0.
     617        !jyg<
     618        ! Etienne: comment those lines since now the TKE is inialized in 1D_read_forc_cases
     619        !!      pbl_tke(:,:,:)=1.e-8
     620        !        pbl_tke(:,:,:)=0.
     621        !        pbl_tke(:,2,:)=1.e-2
     622        !>jyg
     623        rain_fall = 0.
     624        snow_fall = 0.
     625        solsw = 0.
     626        solswfdiff= 0.
     627        sollw = 0.
     628        sollwdown = rsigma*tsurf**4
     629        radsol = 0.
     630        rnebcon= 0.
     631        ratqs = 0.
     632        clwcon = 0.
     633                zmax0 = 0.
     634                zmea = zsurf
     635                zstd= 0.
     636        zsig = 0.
     637        zgam = 0.
     638                zval = 0.
     639                zthe = 0.
     640                sig1= 0.
     641        w01 = 0.
    654642
    655643        wake_deltaq = 0.
    656         wake_deltat = 0.
    657         wake_delta_pbl_TKE(:,:,:) = 0.
     644                wake_deltat = 0.
     645                wake_delta_pbl_TKE(:, :, :) = 0.
    658646        delta_tsurf = 0.
    659647        wake_fip = 0.
    660         wake_pe = 0.
    661         wake_s = 0.
    662         awake_s = 0.
    663         wake_dens = 0.
    664         awake_dens = 0.
    665         cv_gen = 0.
    666         wake_cstar = 0.
    667         ale_bl = 0.
    668         ale_bl_trig = 0.
    669         alp_bl = 0.
    670         IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
    671         IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
    672         entr_therm = 0.
    673         detr_therm = 0.
     648                wake_pe = 0.
     649                wake_s = 0.
     650                awake_s = 0.
     651                wake_dens = 0.
     652                awake_dens = 0.
     653                cv_gen = 0.
     654                wake_cstar = 0.
     655                ale_bl = 0.
     656                ale_bl_trig = 0.
     657                alp_bl = 0.
     658                IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
     659                IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
     660                entr_therm = 0.
     661                detr_therm = 0.
    674662        f0 = 0.
    675663        fm_therm = 0.
    676         u_ancien(1,:)=u(:)
    677         v_ancien(1,:)=v(:)
    678         rneb_ancien(1,:)=0.
    679  
    680         u10m=0.
    681         v10m=0.
    682         ale_wake=0.
    683         ale_bl_stat=0.
    684         ratqs_inter_(:,:)= 0.002
    685 
    686 !------------------------------------------------------------------------
    687 ! Make file containing restart for the physics (startphy.nc)
    688 
    689 ! NB: List of the variables to be written by phyredem (via put_field):
    690 ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
    691 ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
    692 ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
    693 ! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
    694 ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
    695 ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
    696 ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
    697 ! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
    698 ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
    699 
    700 ! NB2: The content of the startphy.nc file depends on some flags defined in
    701 ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have
    702 ! to be set at some arbitratry convenient values.
    703 !------------------------------------------------------------------------
    704 !Al1 =============== restart option ======================================
    705         iflag_physiq=0
    706         CALL getin('iflag_physiq',iflag_physiq)
    707 
    708         if (.not.restart) then
    709           iflag_pbl = 5
    710           CALL phyredem ("startphy.nc")
     664        u_ancien(1, :)= u(:)
     665                v_ancien(1, :)= v(:)
     666                rneb_ancien(1, :)= 0.
     667
     668        u10m = 0.
     669        v10m = 0.
     670        ale_wake = 0.
     671        ale_bl_stat = 0.
     672        ratqs_inter_(:, :)= 0.002
     673
     674        !------------------------------------------------------------------------
     675        ! Make file containing restart for the physics (startphy.nc)
     676
     677        ! NB: List of the variables to be written by phyredem (via put_field):
     678        ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
     679        ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
     680        ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
     681        ! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
     682        ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
     683                ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
     684                ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
     685                ! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
     686                ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
     687
     688                ! NB2: The content of the startphy.nc file depends on some flags defined in
     689                ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have
     690                ! to be set at some arbitratry convenient values.
     691                !------------------------------------------------------------------------
     692                !Al1 =============== restart option ======================================
     693                iflag_physiq = 0
     694                CALL getin('iflag_physiq', iflag_physiq)
     695
     696                if (.not.restart) then
     697        iflag_pbl = 5
     698        CALL phyredem ("startphy.nc")
    711699        else
    712 ! (desallocations)
    713         PRINT*,'callin surf final'
    714           CALL pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)
    715         PRINT*,'after surf final'
    716           CALL fonte_neige_final(run_off_lic_0)
    717         endif
    718 
    719         ok_writedem=.FALSE.
    720         PRINT*,'apres phyredem'
    721 
    722       endif ! ok_writedem
    723      
    724 !------------------------------------------------------------------------
    725 ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
    726 ! --------------------------------------------------
    727 ! NB: List of the variables to be written in limit.nc
    728 !     (by writelim.F, SUBROUTINE of 1DUTILS.h):
    729 !        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
    730 !        phy_fter,phy_foce,phy_flic,phy_fsic)
    731 !------------------------------------------------------------------------
    732       do i=1,year_len
    733         phy_nat(i)  = nat_surf
    734         phy_alb(i)  = albedo
     700        ! (desallocations)
     701        PRINT*, 'callin surf final'
     702        CALL pbl_surface_final(fder, snsrf, qsurfsrf, tsoil)
     703                PRINT*, 'after surf final'
     704                CALL fonte_neige_final(run_off_lic_0)
     705                endif
     706
     707                ok_writedem = .FALSE.
     708                PRINT*,'apres phyredem'
     709
     710                endif ! ok_writedem
     711
     712                !------------------------------------------------------------------------
     713                ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
     714                ! --------------------------------------------------
     715                ! NB: List of the variables to be written in limit.nc
     716                !     (by writelim.F, SUBROUTINE of 1DUTILS.h):
     717                !        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
     718        !        phy_fter,phy_foce,phy_flic,phy_fsic)
     719                !------------------------------------------------------------------------
     720                do i = 1, year_len
     721                phy_nat(i)  = nat_surf
     722                phy_alb(i)  = albedo
    735723        phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
    736724        phy_rug(i)  = rugos
    737         phy_fter(i) = pctsrf(1,is_ter)
    738         phy_foce(i) = pctsrf(1,is_oce)
    739         phy_fsic(i) = pctsrf(1,is_sic)
    740         phy_flic(i) = pctsrf(1,is_lic)
    741       enddo
    742 
    743 ! fabrication de limit.nc
    744       CALL writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,            &
    745                  phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)
    746 
    747 
    748       CALL phys_state_var_end
    749 !Al1
    750       if (restart) then
    751         PRINT*,'CALL to restart dyn 1d'
    752         Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs,          &
    753                 u,v,temp,q,omega2)
    754 
    755        PRINT*,'fnday,annee_ref,day_ref,day_ini',                            &
    756        fnday,annee_ref,day_ref,day_ini
    757 !**      CALL ymds2ju(annee_ref,mois,day_ini,heure,day)
    758        day = day_ini
    759        day_end = day_ini + nday
    760        daytime = day + time_ini/24. ! 1st day and initial time of the simulation
    761 
    762 ! Print out the actual date of the beginning of the simulation :
    763        CALL ju2ymds(daytime, an, mois, jour, heure)
    764        print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.
    765 
    766        day = int(daytime)
    767        time=daytime-day
    768  
    769        PRINT*,'****** intialised fields from restart1dyn *******'
    770        PRINT*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
    771        PRINT*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
    772        PRINT*,temp(1),q(1,1),u(1),v(1),plev(1),phis(1)
    773 ! raz for safety
    774        do l=1,llm
    775          d_q_vert_adv(l,1) = 0.
    776        enddo
    777       endif
    778 !======================  end restart =================================
    779       IF (ecrit_slab_oc==1) then
    780          open(97,file='div_slab.dat',STATUS='UNKNOWN')
    781        elseif (ecrit_slab_oc==0) then
    782          open(97,file='div_slab.dat',STATUS='OLD')
    783        endif
    784 
    785 !=====================================================================
    786 IF (CPP_OUTPUTPHYSSCM) THEN
    787        CALL iophys_ini(timestep)
    788 END IF
    789 
    790 !=====================================================================
    791 ! START OF THE TEMPORAL LOOP :
    792 !=====================================================================
    793            
    794       it_end = nint(fnday*day_step)
    795       do while(it<=it_end)
    796 
    797        if (prt_level>=1) then
    798          PRINT*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                      &
    799                it,day,time,it_end,day_step
    800          PRINT*,'PAS DE TEMPS ',timestep
    801        endif
    802        if (it==it_end) lastcall=.True.
    803 
    804 !---------------------------------------------------------------------
    805 ! Interpolation of forcings in time and onto model levels
    806 !---------------------------------------------------------------------
    807 
    808       INCLUDE "1D_interp_cases.h"
    809 
    810 !---------------------------------------------------------------------
    811 !  Geopotential :
    812 !---------------------------------------------------------------------
    813         phis(1)=zsurf*RG
    814 !        phi(1)=phis(1)+RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
     725        phy_fter(i) = pctsrf(1, is_ter)
     726                phy_foce(i) = pctsrf(1, is_oce)
     727                phy_fsic(i) = pctsrf(1, is_sic)
     728                phy_flic(i) = pctsrf(1, is_lic)
     729        enddo
     730
     731        ! fabrication de limit.nc
     732        CALL writelim (1, phy_nat, phy_alb, phy_sst, phy_bil,phy_rug, &
     733        phy_ice, phy_fter, phy_foce, phy_flic,phy_fsic)
     734
     735
     736                CALL phys_state_var_end
     737                !Al1
     738                if (restart) then
     739                PRINT*, 'CALL to restart dyn 1d'
     740                Call dyn1deta0("start1dyn.nc", plev, play, phi, phis,presnivs, &
     741                u, v, temp, q,omega2)
     742
     743                PRINT*, 'fnday,annee_ref,day_ref,day_ini', &
     744                fnday, annee_ref,day_ref, day_ini
     745                !**      CALL ymds2ju(annee_ref,mois,day_ini,heure,day)
     746                day = day_ini
     747                day_end = day_ini + nday
     748                daytime = day + time_ini/24. ! 1st day and initial time of the simulation
     749
     750                ! Print out the actual date of the beginning of the simulation :
     751                CALL ju2ymds(daytime, an, mois, jour, heure)
     752        print *, ' Time of beginning : y m d h', an, mois,jour, heure/3600.
     753
     754        day = int(daytime)
     755                time = daytime-day
     756
     757                PRINT*,'****** intialised fields from restart1dyn *******'
     758                PRINT*, 'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
     759                PRINT*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
     760                PRINT*, temp(1), q(1, 1), u(1), v(1), plev(1), phis(1)
     761                ! raz for safety
     762                do l = 1, llm
     763                d_q_vert_adv(l, 1) = 0.
     764                enddo
     765                endif
     766                !======================  end restart =================================
     767                IF (ecrit_slab_oc==1) then
     768        open(97, file = 'div_slab.dat', STATUS = 'UNKNOWN')
     769                elseif (ecrit_slab_oc==0) then
     770                open(97, file = 'div_slab.dat', STATUS = 'OLD')
     771                endif
     772
     773                !=====================================================================
     774                IF (CPPKEY_OUTPUTPHYSSCM) THEN
     775                CALL iophys_ini(timestep)
     776        END IF
     777
     778        !=====================================================================
     779        ! START OF THE TEMPORAL LOOP :
     780        !=====================================================================
     781
     782        it_end = nint(fnday*day_step)
     783                do while(it<=it_end)
     784
     785                if (prt_level>=1) then
     786        PRINT*, 'XXXXXXXXXXXXXXXXXXX ITAP,day,time=', &
     787        it, day, time, it_end, day_step
     788        PRINT*,'PAS DE TEMPS ', timestep
     789        endif
     790        if (it==it_end) lastcall = .True.
     791
     792        !---------------------------------------------------------------------
     793        ! Interpolation of forcings in time and onto model levels
     794        !---------------------------------------------------------------------
     795
     796        INCLUDE "1D_interp_cases.h"
     797
     798                !---------------------------------------------------------------------
     799                !  Geopotential :
     800                !---------------------------------------------------------------------
     801                phis(1)= zsurf*RG
     802        !        phi(1)=phis(1)+RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
    815803
    816804        ! Calculate geopotential from the ground surface since phi and phis are added in physiq_mod
    817         phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
    818 
    819         do l = 1, llm-1
    820           phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
    821       (play(l)-play(l+1))/(play(l)+play(l+1))
    822         enddo
    823 
    824 !---------------------------------------------------------------------
    825 !  Vertical advection
    826 !---------------------------------------------------------------------
    827 
    828    IF ( forc_w+forc_omega > 0 ) THEN
    829 
    830       IF ( forc_w == 1 ) THEN
    831          w_adv=w_mod_cas
    832          z_adv=phi/RG
    833       ELSE
    834          w_adv=omega
    835          z_adv=play
    836       ENDIF
    837 
    838       teta=temp*(pzero/play)**rkappa
    839       do l=2,llm-1
     805        phi(1)= RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
     806
     807                do l = 1, llm-1
     808                phi(l+1)= phi(l)+RD*(temp(l)+temp(l+1))*                           &
     809        (play(l)-play(l+1))/(play(l)+play(l+1))
     810                enddo
     811
     812                !---------------------------------------------------------------------
     813                !  Vertical advection
     814                !---------------------------------------------------------------------
     815
     816                IF (forc_w+forc_omega > 0) THEN
     817
     818                IF (forc_w == 1) THEN
     819                w_adv = w_mod_cas
     820                z_adv = phi/RG
     821                ELSE
     822                w_adv = omega
     823                z_adv =play
     824        ENDIF
     825
     826        teta = temp*(pzero/play)**rkappa
     827        do l = 2, llm-1
    840828        ! vertical tendencies computed as d X / d t = -W  d X / d z
    841         d_u_vert_adv(l)=-w_adv(l)*(u(l+1)-u(l-1))/(z_adv(l+1)-z_adv(l-1))
    842         d_v_vert_adv(l)=-w_adv(l)*(v(l+1)-v(l-1))/(z_adv(l+1)-z_adv(l-1))
    843         ! d theta / dt = -W d theta / d z, transformed into d temp / d t dividing by (pzero/play(l))**rkappa
    844         d_t_vert_adv(l)=-w_adv(l)*(teta(l+1)-teta(l-1))/(z_adv(l+1)-z_adv(l-1)) / (pzero/play(l))**rkappa
    845         d_q_vert_adv(l,1)=-w_adv(l)*(q(l+1,1)-q(l-1,1))/(z_adv(l+1)-z_adv(l-1))
    846       enddo
    847       d_u_adv(:)=d_u_adv(:)+d_u_vert_adv(:)
    848       d_v_adv(:)=d_v_adv(:)+d_v_vert_adv(:)
    849       d_t_adv(:)=d_t_adv(:)+d_t_vert_adv(:)
    850       d_q_adv(:,1)=d_q_adv(:,1)+d_q_vert_adv(:,1)
    851    
    852    ENDIF
    853 
    854 !---------------------------------------------------------------------
    855 ! Listing output for debug prt_level>=1
    856 !---------------------------------------------------------------------
    857        if (prt_level>=1) then
    858          print *,' avant physiq : -------- day time ',day,time
    859          write(*,*) 'firstcall,lastcall,phis',                               &
    860                  firstcall,lastcall,phis
    861        end if
    862        if (prt_level>=5) then
    863          write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l',                   &
    864           'presniv','plev','play','phi'
    865          write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l,                   &
    866            presnivs(l),plev(l),play(l),phi(l),l=1,llm)
    867          write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l',                    &
    868            'presniv','u','v','temp','q1','q2','omega2'
    869          write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l,         &
    870      presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
    871        endif
    872 
    873 !---------------------------------------------------------------------
    874 !   Call physiq :
    875 !---------------------------------------------------------------------
    876        CALL physiq(ngrid,llm, &
    877                     firstcall,lastcall,timestep, &
    878                     plev,play,phi,phis,presnivs, &
    879                     u,v, rot, temp,q,omega2, &
    880                     du_phys,dv_phys,dt_phys,dq,dpsrf)
    881                 firstcall=.FALSE.
    882 
    883 !---------------------------------------------------------------------
    884 ! Listing output for debug
    885 !---------------------------------------------------------------------
    886         if (prt_level>=5) then
    887           write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l',                  &
    888           'presniv','plev','play','phi'
    889           write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l,                  &
    890       presnivs(l),plev(l),play(l),phi(l),l=1,llm)
    891           write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l',                   &
    892            'presniv','u','v','temp','q1','q2','omega2'
    893           write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l,       &
    894       presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
    895           write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l',                   &
    896            'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'
    897            write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l,            &
    898         presnivs(l),86400*du_phys(l),86400*dv_phys(l),                   &
    899          86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)
    900           write(*,*) 'dpsrf',dpsrf
     829        d_u_vert_adv(l)= -w_adv(l)*(u(l+1)-u(l-1))/(z_adv(l+1)-z_adv(l-1))
     830                d_v_vert_adv(l)= -w_adv(l)*(v(l+1)-v(l-1))/(z_adv(l+1)-z_adv(l-1))
     831                        ! d theta / dt = -W d theta / d z, transformed into d temp / d t dividing by (pzero/play(l))**rkappa
     832                        d_t_vert_adv(l)= -w_adv(l)*(teta(l+1)-teta(l-1))/(z_adv(l+1)-z_adv(l-1)) / (pzero/play(l))**rkappa
     833                d_q_vert_adv(l, 1)= -w_adv(l)*(q(l+1, 1)-q(l-1, 1))/(z_adv(l+1)-z_adv(l-1))
     834                        enddo
     835                        d_u_adv(:)= d_u_adv(:)+d_u_vert_adv(:)
     836                        d_v_adv(:)= d_v_adv(:)+d_v_vert_adv(:)
     837                        d_t_adv(:)= d_t_adv(:)+d_t_vert_adv(:)
     838                        d_q_adv(:, 1)= d_q_adv(:, 1)+d_q_vert_adv(:, 1)
     839
     840                ENDIF
     841
     842                !---------------------------------------------------------------------
     843                ! Listing output for debug prt_level>=1
     844                !---------------------------------------------------------------------
     845                if (prt_level>=1) then
     846                print *, ' avant physiq : -------- day time ', day, time
     847                        write(*, *) 'firstcall,lastcall,phis', &
     848                firstcall, lastcall, phis
     849                end if
     850                        if (prt_level>=5) then
     851                write(*, '(a10,2a4,4a13)') 'BEFOR1 IT=', 'it', 'l', &
     852                'presniv', 'plev','play', 'phi'
     853                write(*, '(a10,2i4,4f13.2)') ('BEFOR1 IT= ', it, l, &
     854                presnivs(l), plev(l), play(l), phi(l), l = 1, llm)
     855                        write(*, '(a11,2a4,a11,6a8)') 'BEFOR2', 'it', 'l', &
     856                        'presniv', 'u','v', 'temp', 'q1', 'q2', 'omega2'
     857                        write(*, '(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ', it, l, &
     858                presnivs(l), u(l), v(l), temp(l), q(l, 1), q(l, 2), omega2(l), l = 1, llm)
     859                        endif
     860
     861                        !---------------------------------------------------------------------
     862                        !   Call physiq :
     863                        !---------------------------------------------------------------------
     864                        CALL physiq(ngrid, llm, &
     865                        firstcall, lastcall, timestep, &
     866                        plev, play, phi, phis, presnivs, &
     867                        u, v, rot, temp, q,omega2, &
     868                        du_phys, dv_phys, dt_phys, dq,dpsrf)
     869                        firstcall = .FALSE.
     870
     871                        !---------------------------------------------------------------------
     872                        ! Listing output for debug
     873                        !---------------------------------------------------------------------
     874                        if (prt_level>=5) then
     875                        write(*, '(a11,2a4,4a13)') 'AFTER1 IT=', 'it', 'l', &
     876                        'presniv', 'plev','play', 'phi'
     877                        write(*, '(a11,2i4,4f13.2)') ('AFTER1 it= ', it, l, &
     878                presnivs(l), plev(l), play(l), phi(l), l = 1, llm)
     879                        write(*, '(a11,2a4,a11,6a8)') 'AFTER2', 'it', 'l', &
     880                        'presniv', 'u','v', 'temp', 'q1', 'q2', 'omega2'
     881                        write(*, '(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ', it, l, &
     882                        presnivs(l), u(l), v(l), temp(l), q(l, 1), q(l, 2), omega2(l), l = 1, llm)
     883                        write(*, '(a11,2a4,a11,5a8)') 'AFTER3', 'it', 'l', &
     884        'presniv', 'du_phys','dv_phys', 'dt_phys', 'dq1', 'dq2'
     885        write(*, '(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ', it, l, &
     886        presnivs(l), 86400*du_phys(l), 86400*dv_phys(l), &
     887        86400*dt_phys(l), 86400*dq(l, 1), dq(l, 2), l = 1, llm)
     888                write(*, *) 'dpsrf', dpsrf
     889                endif
     890                !---------------------------------------------------------------------
     891                !   Add physical tendencies :
     892                !---------------------------------------------------------------------
     893
     894                fcoriolis= 2.*sin(rpi*xlat/180.)*romega
     895
     896                IF (prt_level >= 5) PRINT*, 'fcoriolis, xlat,mxcalc ', &
     897        fcoriolis, xlat, mxcalc
     898
     899        !---------------------------------------------------------------------
     900        ! Geostrophic forcing
     901        !---------------------------------------------------------------------
     902
     903        IF (forc_geo == 0) THEN
     904        d_u_age(1:mxcalc)= 0.
     905        d_v_age(1:mxcalc)= 0.
     906        ELSE
     907        sfdt = sin(0.5*fcoriolis*timestep)
     908                cfdt = cos(0.5*fcoriolis*timestep)
     909
     910        d_u_age(1:mxcalc)= -2.*sfdt/timestep*                                &
     911        (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
     912                cfdt*(v(1:mxcalc)-vg(1:mxcalc)))
     913                !!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
     914
     915                d_v_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
     916        (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
     917                sfdt*(v(1:mxcalc)-vg(1:mxcalc)))
     918                !!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
     919                ENDIF
     920
     921                !---------------------------------------------------------------------
     922                !  Nudging
     923                !  EV: rewrite the section to account for a time- and height-varying
     924                !  nudging
     925                !---------------------------------------------------------------------
     926                d_t_nudge(:) = 0.
     927        d_u_nudge(:) = 0.
     928        d_v_nudge(:) = 0.
     929        d_q_nudge(:, :) = 0.
     930
     931        DO l = 1, llm
     932
     933                IF (nudging_u < 0) THEN
     934
     935                d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))*invtau_u_nudg_mod_cas(l)
     936
     937                ELSE
     938
     939                IF (play(l) < p_nudging_u .AND. nint(nudging_u) /= 0) &
     940                d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))/nudging_u
     941
     942        ENDIF
     943
     944
     945        IF (nudging_v < 0) THEN
     946
     947        d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))*invtau_v_nudg_mod_cas(l)
     948
     949                ELSE
     950
     951
     952                IF (play(l) < p_nudging_v .AND. nint(nudging_v) /= 0) &
     953        d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))/nudging_v
     954
     955        ENDIF
     956
     957
     958        IF (nudging_t < 0) THEN
     959
     960        d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))*invtau_temp_nudg_mod_cas(l)
     961
     962                ELSE
     963
     964
     965                IF (play(l) < p_nudging_t .AND. nint(nudging_t) /= 0) &
     966                d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))/nudging_t
     967
     968                ENDIF
     969
     970
     971                IF (nudging_qv < 0) THEN
     972
     973        d_q_nudge(l, 1)=(qv_nudg_mod_cas(l)-q(l, 1))*invtau_qv_nudg_mod_cas(l)
     974
     975                ELSE
     976
     977                IF (play(l) < p_nudging_qv .AND. nint(nudging_qv) /= 0) &
     978                d_q_nudge(l, 1)=(qv_nudg_mod_cas(l)-q(l, 1))/nudging_qv
     979
     980        ENDIF
     981
     982        ENDDO
     983
     984        !---------------------------------------------------------------------
     985        !  Optional outputs
     986        !---------------------------------------------------------------------
     987
     988                IF (CPPKEY_OUTPUTPHYSSCM) THEN
     989                CALL iophys_ecrit('w_adv', klev, 'w_adv', 'K/day', w_adv)
     990                CALL iophys_ecrit('z_adv', klev, 'z_adv', 'K/day', z_adv)
     991                CALL iophys_ecrit('dtadv', klev, 'dtadv', 'K/day', 86400*d_t_adv)
     992        CALL iophys_ecrit('dtdyn', klev, 'dtdyn', 'K/day', 86400*d_t_vert_adv)
     993                CALL iophys_ecrit('qv', klev, 'qv', 'g/kg', 1000*q(:, 1))
     994                CALL iophys_ecrit('qvnud', klev, 'qvnud', 'g/kg', 1000*u_nudg_mod_cas)
     995                CALL iophys_ecrit('u', klev, 'u', 'm/s', u)
     996                CALL iophys_ecrit('unud', klev, 'unud', 'm/s', u_nudg_mod_cas)
     997        CALL iophys_ecrit('v', klev, 'v', 'm/s', v)
     998                CALL iophys_ecrit('vnud', klev, 'vnud', 'm/s', v_nudg_mod_cas)
     999                CALL iophys_ecrit('temp', klev, 'temp', 'K', temp)
     1000                CALL iophys_ecrit('tempnud', klev, 'temp_nudg_mod_cas', 'K', temp_nudg_mod_cas)
     1001                CALL iophys_ecrit('dtnud', klev, 'dtnud', 'K/day', 86400*d_t_nudge)
     1002        CALL iophys_ecrit('dqnud', klev, 'dqnud', 'K/day', 1000*86400*d_q_nudge(:, 1))
     1003                END IF
     1004
     1005                IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
     1006
     1007        u(1:mxcalc)= u(1:mxcalc) + timestep*(&
     1008        du_phys(1:mxcalc)                                       &
     1009        +d_u_age(1:mxcalc)+d_u_adv(1:mxcalc)                       &
     1010        +d_u_nudge(1:mxcalc))
     1011        v(1:mxcalc)= v(1:mxcalc) + timestep*(&
     1012        dv_phys(1:mxcalc)                                       &
     1013        +d_v_age(1:mxcalc)+d_v_adv(1:mxcalc)                       &
     1014        +d_v_nudge(1:mxcalc))
     1015                q(1:mxcalc, :)= q(1:mxcalc, :)+timestep*(&
     1016        dq(1:mxcalc, :)                                        &
     1017        +d_q_adv(1:mxcalc, :)                                   &
     1018        +d_q_nudge(1:mxcalc, :))
     1019
     1020                if (prt_level>=3) then
     1021                print *, &
     1022                'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ', &
     1023                temp(1), dt_phys(1), d_t_adv(1), dt_cooling(1)
     1024                PRINT*, 'dv_phys=', dv_phys
     1025                PRINT* , 'd_v_age=', d_v_age
     1026                PRINT*, 'd_v_adv=',d_v_adv
     1027                PRINT*, 'd_v_nudge=', d_v_nudge
     1028                PRINT*, v
     1029                PRINT*, vg
     1030                endif
     1031
     1032                temp(1:mxcalc)= temp(1:mxcalc)+timestep*(&
     1033        dt_phys(1:mxcalc)                                       &
     1034        +d_t_adv(1:mxcalc)                                       &
     1035        +d_t_nudge(1:mxcalc)                                     &
     1036        +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
     1037
     1038
     1039        !=======================================================================
     1040        !! CONSERVE EN ATTENDANT QUE LE CAS EN QUESTION FONCTIONNE EN STD !!
     1041        !=======================================================================
     1042
     1043        teta = temp*(pzero/play)**rkappa
     1044
     1045        !---------------------------------------------------------------------
     1046        !   Nudge soil temperature if requested
     1047        !---------------------------------------------------------------------
     1048
     1049        IF (nudge_tsoil .AND. .NOT. lastcall) THEN
     1050        ftsoil(1, isoil_nudge, :) = ftsoil(1, isoil_nudge, :)                     &
     1051        -timestep/tau_soil_nudge*(ftsoil(1, isoil_nudge, :)-Tsoil_nudge)
     1052                ENDIF
     1053
     1054                !---------------------------------------------------------------------
     1055                !   Add large-scale tendencies (advection, etc) :
     1056                !---------------------------------------------------------------------
     1057
     1058                !cc nrlmd
     1059                !cc        tmpvar=teta
     1060                !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
     1061                !cc
     1062        !cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
     1063                !cc        tmpvar(:)=q(:,1)
     1064                !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
     1065                !cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
     1066                !cc        tmpvar(:)=q(:,2)
     1067                !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
     1068                !cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
     1069
     1070                END IF ! end if tendency of tendency should be added
     1071
     1072                !---------------------------------------------------------------------
     1073                !   Air temperature :
     1074                !---------------------------------------------------------------------
     1075                if (lastcall) then
     1076                PRINT*, 'Pas de temps final ', it
     1077                CALL ju2ymds(daytime, an, mois, jour, heure)
     1078                PRINT*, 'a la date : a m j h', an, mois, jour, heure/3600.
    9011079        endif
    902 !---------------------------------------------------------------------
    903 !   Add physical tendencies :
    904 !---------------------------------------------------------------------
    905 
    906        fcoriolis=2.*sin(rpi*xlat/180.)*romega
    907 
    908       IF (prt_level >= 5) PRINT*, 'fcoriolis, xlat,mxcalc ', &
    909                                    fcoriolis, xlat,mxcalc
    910 
    911 !---------------------------------------------------------------------
    912 ! Geostrophic forcing
    913 !---------------------------------------------------------------------
    914 
    915       IF ( forc_geo == 0 ) THEN
    916               d_u_age(1:mxcalc)=0.
    917               d_v_age(1:mxcalc)=0.
    918       ELSE
    919        sfdt = sin(0.5*fcoriolis*timestep)
    920        cfdt = cos(0.5*fcoriolis*timestep)
    921 
    922         d_u_age(1:mxcalc)= -2.*sfdt/timestep*                                &
    923             (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
    924              cfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
    925 !!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
    926 
    927        d_v_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
    928             (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
    929              sfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
    930 !!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
    931       ENDIF
    932 
    933 !---------------------------------------------------------------------
    934 !  Nudging
    935 !  EV: rewrite the section to account for a time- and height-varying
    936 !  nudging
    937 !---------------------------------------------------------------------
    938       d_t_nudge(:) = 0.
    939       d_u_nudge(:) = 0.
    940       d_v_nudge(:) = 0.
    941       d_q_nudge(:,:) = 0.
    942 
    943       DO l=1,llm
    944 
    945          IF (nudging_u < 0) THEN
    946              
    947              d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))*invtau_u_nudg_mod_cas(l)
    948        
    949          ELSE
    950 
    951              IF ( play(l) < p_nudging_u .AND. nint(nudging_u) /= 0 ) &
    952    d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))/nudging_u
    953 
    954          ENDIF
    955 
    956 
    957          IF (nudging_v < 0) THEN
    958              
    959              d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))*invtau_v_nudg_mod_cas(l)
    960        
    961          ELSE
    962 
    963 
    964              IF ( play(l) < p_nudging_v .AND. nint(nudging_v) /= 0 ) &
    965    d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))/nudging_v
    966 
    967          ENDIF
    968 
    969 
    970          IF (nudging_t < 0) THEN
    971              
    972              d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))*invtau_temp_nudg_mod_cas(l)
    973        
    974          ELSE
    975 
    976 
    977              IF ( play(l) < p_nudging_t .AND. nint(nudging_t) /= 0 ) &
    978    d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))/nudging_t
    979 
    980           ENDIF
    981 
    982 
    983          IF (nudging_qv < 0) THEN
    984              
    985              d_q_nudge(l,1)=(qv_nudg_mod_cas(l)-q(l,1))*invtau_qv_nudg_mod_cas(l)
    986        
    987          ELSE
    988 
    989              IF ( play(l) < p_nudging_qv .AND. nint(nudging_qv) /= 0 ) &
    990    d_q_nudge(l,1)=(qv_nudg_mod_cas(l)-q(l,1))/nudging_qv
    991 
    992          ENDIF
    993 
    994       ENDDO
    995 
    996 !---------------------------------------------------------------------
    997 !  Optional outputs
    998 !---------------------------------------------------------------------
    999 
    1000 IF (CPP_OUTPUTPHYSSCM) THEN
    1001       CALL iophys_ecrit('w_adv',klev,'w_adv','K/day',w_adv)
    1002       CALL iophys_ecrit('z_adv',klev,'z_adv','K/day',z_adv)
    1003       CALL iophys_ecrit('dtadv',klev,'dtadv','K/day',86400*d_t_adv)
    1004       CALL iophys_ecrit('dtdyn',klev,'dtdyn','K/day',86400*d_t_vert_adv)
    1005       CALL iophys_ecrit('qv',klev,'qv','g/kg',1000*q(:,1))
    1006       CALL iophys_ecrit('qvnud',klev,'qvnud','g/kg',1000*u_nudg_mod_cas)
    1007       CALL iophys_ecrit('u',klev,'u','m/s',u)
    1008       CALL iophys_ecrit('unud',klev,'unud','m/s',u_nudg_mod_cas)
    1009       CALL iophys_ecrit('v',klev,'v','m/s',v)
    1010       CALL iophys_ecrit('vnud',klev,'vnud','m/s',v_nudg_mod_cas)
    1011       CALL iophys_ecrit('temp',klev,'temp','K',temp)
    1012       CALL iophys_ecrit('tempnud',klev,'temp_nudg_mod_cas','K',temp_nudg_mod_cas)
    1013       CALL iophys_ecrit('dtnud',klev,'dtnud','K/day',86400*d_t_nudge)
    1014       CALL iophys_ecrit('dqnud',klev,'dqnud','K/day',1000*86400*d_q_nudge(:,1))
    1015 END IF
    1016 
    1017     IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
    1018 
    1019         u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &
    1020                 du_phys(1:mxcalc)                                       &
    1021                +d_u_age(1:mxcalc)+d_u_adv(1:mxcalc)                       &
    1022                +d_u_nudge(1:mxcalc) )
    1023         v(1:mxcalc)=v(1:mxcalc) + timestep*(                                 &
    1024                 dv_phys(1:mxcalc)                                       &
    1025                +d_v_age(1:mxcalc)+d_v_adv(1:mxcalc)                       &
    1026                +d_v_nudge(1:mxcalc) )
    1027         q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(                              &
    1028                   dq(1:mxcalc,:)                                        &
    1029                  +d_q_adv(1:mxcalc,:)                                   &
    1030                  +d_q_nudge(1:mxcalc,:) )
    1031 
    1032         if (prt_level>=3) then
    1033           print *,                                                          &
    1034       'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ',         &
    1035                 temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)
    1036            PRINT* ,'dv_phys=',dv_phys
    1037            PRINT* ,'d_v_age=',d_v_age
    1038            PRINT* ,'d_v_adv=',d_v_adv
    1039            PRINT* ,'d_v_nudge=',d_v_nudge
    1040            PRINT*, v
    1041            PRINT*, vg
    1042         endif
    1043 
    1044         temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
    1045                 dt_phys(1:mxcalc)                                       &
    1046                +d_t_adv(1:mxcalc)                                       &
    1047                +d_t_nudge(1:mxcalc)                                     &
    1048                +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
    1049 
    1050 
    1051 !=======================================================================
    1052 !! CONSERVE EN ATTENDANT QUE LE CAS EN QUESTION FONCTIONNE EN STD !!
    1053 !=======================================================================
    1054 
    1055         teta=temp*(pzero/play)**rkappa
    1056 
    1057 !---------------------------------------------------------------------
    1058 !   Nudge soil temperature if requested
    1059 !---------------------------------------------------------------------
    1060 
    1061       IF (nudge_tsoil .AND. .NOT. lastcall) THEN
    1062        ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
    1063     -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
    1064       ENDIF
    1065 
    1066 !---------------------------------------------------------------------
    1067 !   Add large-scale tendencies (advection, etc) :
    1068 !---------------------------------------------------------------------
    1069 
    1070 !cc nrlmd
    1071 !cc        tmpvar=teta
    1072 !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
    1073 !cc
    1074 !cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
    1075 !cc        tmpvar(:)=q(:,1)
    1076 !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
    1077 !cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
    1078 !cc        tmpvar(:)=q(:,2)
    1079 !cc        CALL advect_vert(llm,omega,timestep,tmpvar,plev)
    1080 !cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
    1081 
    1082    END IF ! end if tendency of tendency should be added
    1083 
    1084 !---------------------------------------------------------------------
    1085 !   Air temperature :
    1086 !---------------------------------------------------------------------       
    1087         if (lastcall) then
    1088           PRINT*,'Pas de temps final ',it
    1089           CALL ju2ymds(daytime, an, mois, jour, heure)
    1090           PRINT*,'a la date : a m j h',an, mois, jour ,heure/3600.
    1091         endif
    1092 
    1093 !  incremente day time
     1080
     1081        !  incremente day time
    10941082        daytime = daytime+1./day_step
    10951083        day = int(daytime+0.1/day_step)
    1096 !        time = max(daytime-day,0.0)
    1097 !Al1&jyg: correction de bug
    1098 !cc        time = real(mod(it,day_step))/day_step
    1099         time = time_ini/24.+real(mod(it,day_step))/day_step
    1100         it=it+1
    1101 
    1102       enddo
    1103 
    1104       if (ecrit_slab_oc/=-1) close(97)
    1105 
    1106 !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
    1107 ! ---------------------------------------------------------------------------
    1108        CALL dyn1dredem("restart1dyn.nc",                                    &
    1109                 plev,play,phi,phis,presnivs,                            &
    1110                 u,v,temp,q,omega2)
    1111 
    1112         CALL abort_gcm ('lmdz1d   ','The End  ',0)
     1084                !        time = max(daytime-day,0.0)
     1085                !Al1&jyg: correction de bug
     1086                !cc        time = real(mod(it,day_step))/day_step
     1087                time = time_ini/24.+real(mod(it, day_step))/day_step
     1088                it = it+1
     1089
     1090                enddo
     1091
     1092                if (ecrit_slab_oc/=-1) close(97)
     1093
     1094        !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
     1095        ! ---------------------------------------------------------------------------
     1096        CALL dyn1dredem("restart1dyn.nc", &
     1097        plev, play, phi, phis,presnivs, &
     1098        u, v, temp, q,omega2)
     1099
     1100        CALL abort_gcm ('lmdz1d   ', 'The End  ', 0)
    11131101
    11141102END SUBROUTINE scm
     1103END MODULE lmdz_scm
Note: See TracChangeset for help on using the changeset viewer.