Ignore:
Timestamp:
Aug 2, 2024, 9:58:25 PM (5 months ago)
Author:
abarral
Message:

Put dimensions.h and paramet.h into modules

Location:
LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm
Files:
38 edited

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/aeropt_5wv_rrtm.F90

    r5133 r5159  
    1 !
     1
    22! $Id: aeropt_5wv_rrtm.F90 3288 2018-03-19 20:58:31Z oboucher $
    33!
    … …  
    1616  USE YOMCST, ONLY: RD,RG
    1717
    18   !
     18
    1919  !    Yves Balkanski le 12 avril 2006
    2020  !    Celine Deandreis
    … …  
    2323  !    Olivier Boucher mars 2014 pour adaptation RRTM
    2424  !   
    25   !
     25
    2626  ! Refractive indices for seasalt come from Shettle and Fenn (1979)
    27   !
     27
    2828  ! Refractive indices from water come from Hale and Querry (1973)
    29   !
     29
    3030  ! Refractive indices from Ammonium Sulfate Toon and Pollack (1976)
    31   !
     31
    3232  ! Refractive indices for Dust, internal mixture of minerals coated with 1.5% hematite
    3333  ! by Volume (Balkanski et al., 2006)
    34   !
     34
    3535  ! Refractive indices for POM: Kinne (pers. Communication
    36   !
     36
    3737  ! Refractive index for BC from Shettle and Fenn (1979)
    38   !
     38
    3939  ! Shettle, E. P., & Fenn, R. W. (1979), Models for the aerosols of the lower atmosphere and
    4040  ! the effects of humidity variations on their optical properties, U.S. Air Force Geophysics
    4141  ! Laboratory Rept. AFGL-TR-79-0214, Hanscomb Air Force Base, MA.
    42   !
     42
    4343  ! Hale, G. M. and M. R. Querry, Optical constants of water in the 200-nm to 200-m
    4444  ! wavelength region, Appl. Opt., 12, 555-563, 1973.
    45   !
     45
    4646  ! Toon, O. B. and J. B. Pollack, The optical constants of several atmospheric aerosol species:
    4747  ! Ammonium sulfate, aluminum oxide, and sodium chloride, J. Geohys. Res., 81, 5733-5748,
    4848  ! 1976.
    49   !
     49
    5050  ! Balkanski, Y., M. Schulz, T. Claquin And O. Boucher, Reevaluation of mineral aerosol
    5151  ! radiative forcings suggests a better agreement with satellite and AERONET data, Atmospheric
    5252  ! Chemistry and Physics Discussions., 6, pp 8383-8419, 2006.
    53   !
     53
    5454  IMPLICIT NONE
    55   !
     55
    5656  ! Input arguments:
    57   !
     57
    5858  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pdel
    5959  REAL, DIMENSION(klon,klev,naero_tot), INTENT(IN) :: m_allaer
    … …  
    6363  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
    6464  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
    65   !
     65
    6666  ! Output arguments:
    67   !
     67
    6868  REAL, DIMENSION(klon), INTENT(OUT)                      :: ai      ! POLDER aerosol index
    6969  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)      :: tausum
    7070  REAL, DIMENSION(klon,naero_tot), INTENT(OUT)            :: drytausum
    7171  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT) :: tau
    72   !
     72
    7373  ! Local
    74   !
     74
    7575  INTEGER, PARAMETER :: las = nwave_sw
    7676  LOGICAL :: soluble
    … …  
    110110  REAL :: abs_aeri_5wv(las,naero_insoluble)           ! Abs. coeff. ** m2/g
    111111
    112   !
     112
    113113  ! BC internal mixture
    114   !
     114
    115115  INTEGER, PARAMETER ::  nbclassbc = 6  ! Added by Rong Wang/OB for the 5 fractions
    116116                                        ! of BC in the soluble mode:
    … …  
    123123  REAL :: abs_MG_5wv(nbre_RH,las,nbclassbc)
    124124
    125   !
     125
    126126  ! Proprietes optiques
    127   !
     127
    128128  REAL :: fact_RH(nbre_RH), BC_massfra
    129129  INTEGER :: n, classbc
    … …  
    196196   ! Nitrate insoluble
    197197  0.726, 0.753, 0.780, 0.797, 0.811 /
    198 !
     198
    199199 DATA abs_aers_5wv/ &
    200200   ! absorption BC Accumulation Soluble (AS)
    … …  
    303303   4.505,  4.505,  4.505,  4.505,  4.520,  4.444,  4.356,  4.243,  4.089,  3.997,  3.912,  4.179, &
    304304   4.295,  4.295,  4.295,  4.295,  4.307,  4.239,  4.157,  4.045,  3.876,  3.757,  3.602,  3.569  /
    305 !
     305
    306306   DATA abs_MG_5wv/ &
    307307 !--BC content=0.001
    … …  
    405405  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
    406406  !      compute optical_thickness_at_gridpoint_per_species
    407   !
     407
    408408  ! Calculations that need to be done since we are not in the subroutines INCA
    409409  !     

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/aeropt_6bands_rrtm.F90

    r5154 r5159  
    1 !
     1
    22! $Id: aeropt_6bands_rrtm.F90 4165 2022-05-26 19:56:53Z oboucher $
    3 !
     3
    44SUBROUTINE AEROPT_6BANDS_RRTM ( &
    55     pdel, m_allaer, RHcl, &
    … …  
    2020  !    Olivier Boucher f�vrier 2014 pour passage � RRTM
    2121  !    a partir des propri�t�s optiques fournies par Yves Balkanski
    22   !
     22
    2323  IMPLICIT NONE
    2424  !!
    2525  ! Input arguments:
    26   !
     26
    2727  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: pdel
    2828  REAL, DIMENSION(klon,klev,naero_tot),   INTENT(IN)  :: m_allaer
    … …  
    3333  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: zrho
    3434  LOGICAL,                        INTENT(IN)  :: ok_volcan ! volcanic diags
    35   !
     35
    3636  ! Output arguments:
    3737  ! 2= total aerosols
    3838  ! 1= natural aerosols
    39   !
     39
    4040  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: tau_allaer ! epaisseur optique aerosol
    4141  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: piz_allaer ! single scattering albedo aerosol
    4242  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: cg_allaer  ! asymmetry parameter aerosol
    43   !
     43
    4444  ! Local
    45   !
     45
    4646  LOGICAL :: soluble
    4747  INTEGER :: i, k,n, inu, m
    … …  
    7777  REAL, DIMENSION(klon,klev,id_ASBCM_phy:id_ASBCM_phy,nbands_sw_rrtm) :: piz_ae_pi
    7878  REAL, DIMENSION(klon,klev,id_ASBCM_phy:id_ASBCM_phy,nbands_sw_rrtm) :: cg_ae_pi
    79   !
     79
    8080  ! Proprietes optiques
    81   !
     81
    8282  REAL:: alpha_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)   !--unit m2/g
    8383  REAL:: alpha_aeri_6bands(nbands_sw_rrtm,naero_insoluble)         !--unit m2/g
    … …  
    8888  !
    8989  ! BC internal mixture
    90   !
     90
    9191  INTEGER, PARAMETER ::  nbclassbc = 6  ! Added by Rong Wang/OB for the 5 fractions
    9292                                        ! of BC in the soluble mode:
    … …  
    9999  REAL :: cg_MG_6bands(nbre_RH,nbands_sw_rrtm,nbclassbc)
    100100  REAL :: piz_MG_6bands(nbre_RH,nbands_sw_rrtm,nbclassbc)
    101   !
     101
    102102  INTEGER :: aerindex, classbc, classbc_pi
    103103  REAL :: tmp_var, tmp_var_pi, BC_massfra, BC_massfra_pi
    104104  CHARACTER*20 :: modname
    105   !
     105
    106106  REAL, PARAMETER :: tau_min = 1.e-7
    107107
    … …  
    526526  ENDIF
    527527
    528   !
     528
    529529  ! loop over modes, use of precalculated nmd and corresponding sigma
    530530  !    loop over wavelengths
    … …  
    796796
    797797         IF (.NOT. ok_volcan) THEN
    798 !
     798
    799799!--this is the default case
    800800!--in this case, index 1 of tau_allaer contains natural aerosols only
    801801!--because the objective is to perform the double radiation call with and without anthropogenic aerosols
    802 !
     802
    803803           tau_allaer(i,k,1,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ &
    804804                                 tau_ae_pi(i,k,id_ASBCM_phy,inu)+tau_ae_pi(i,k,id_AIBCM_phy,inu)+   &
    … …  
    834834                                 (tau_allaer(i,k,1,inu)*piz_allaer(i,k,1,inu))
    835835           cg_allaer(i,k,1,inu)=MIN(MAX(cg_allaer(i,k,1,inu),0.0),1.0)
    836 !
     836
    837837         ELSE
    838 !
     838
    839839!--this is the case for VOLMIP
    840840!--in this case index 1 of tau_allaer contains all (natural+anthropogenic) aerosols (same as index 2 above)
    841841!--but stratospheric aerosols will not be added in rrtm/readaerosolstrato2 as
    842842!--the objective is to have the double radiation call with and without stratospheric aerosols
    843 !
     843
    844844           tau_allaer(i,k,1,inu)=tau_allaer(i,k,2,inu)
    845845           
    … …  
    847847           
    848848           cg_allaer(i,k,1,inu) =cg_allaer(i,k,2,inu)
    849 !
     849
    850850         ENDIF
    851851        ENDDO

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/aeropt_lw_rrtm.F90

    r5154 r5159  
    1 !
     1
    22! aeropt_lw_rrtm.F90 2014-05-13 C. Kleinschmitt
    33!                    2016-05-03 O. Boucher
    44!                    2016-12-17 O. Boucher
    5 !
     5
    66! This routine feeds aerosol LW properties to RRTM
    77! we only consider absorption (not scattering)
    … …  
    2020  IMPLICIT NONE
    2121
    22   !
     22
    2323  ! Input arguments:
    24   !
     24
    2525  LOGICAL, INTENT(IN)                              :: ok_alw
    2626  INTEGER, INTENT(IN)                              :: flag_aerosol
    2727  REAL, DIMENSION(klon,klev), INTENT(IN)           :: pdel, zrho
    2828  REAL, DIMENSION(klon,klev,naero_tot), INTENT(IN) :: m_allaer, m_allaer_pi
    29   !
     29
    3030  INTEGER inu, i, k
    3131  REAL :: zdh(klon,klev)
    3232  REAL :: tmp_var, tmp_var_pi
    3333  CHARACTER*20 modname
    34   !
     34
    3535  !--absorption coefficient for CIDUST
    3636  REAL:: alpha_abs_CIDUST_16bands(nbands_lw_rrtm)   !--unit m2/g
    … …  
    3838  0.001, 0.003, 0.005, 0.006, 0.012, 0.030, 0.148, 0.098, &
    3939  0.017, 0.053, 0.031, 0.008, 0.010, 0.011, 0.013, 0.015  /
    40   !
     40
    4141  modname='aeropt_lw_rrtm'
    42   !
     42
    4343  IF (NLW.NE.nbands_lw_rrtm) THEN
    4444    CALL abort_physic(modname,'Erreur NLW doit etre egal a 16 pour cette routine',1)
    … …  
    4646  !
    4747  IF (ok_alw) THEN                                   !--aerosol LW effects
    48    !
     48
    4949   IF (flag_aerosol.EQ.5.OR.flag_aerosol.EQ.6.OR.flag_aerosol.EQ.7) THEN  !-Dust
    50     !
     50
    5151    zdh(:,:)=pdel(:,:)/(RG*zrho(:,:))      ! m
    52     !
     52
    5353    DO k=1, klev
    5454      DO i=1, klon
    55          !
     55
    5656         tmp_var   =m_allaer(i,k,id_CIDUSTM_phy)   /1.e6*zdh(i,k)  !--g/m2
    5757         tmp_var_pi=m_allaer_pi(i,k,id_CIDUSTM_phy)/1.e6*zdh(i,k)  !--g/m2
    58          !
     58
    5959         DO inu=1, NLW
    60            !
     60
    6161           !--total aerosol
    6262           tau_aero_lw_rrtm(i,k,2,inu) = MAX(1.e-15,tmp_var*alpha_abs_CIDUST_16bands(inu))
    … …  
    6464!           tau_aero_lw_rrtm(:,:,1,inu) = MAX(1.e-15,tmp_var_pi*alpha_abs_CIDUST_16bands(inu))
    6565           tau_aero_lw_rrtm(i,k,1,inu) = 1.e-15  !--test
    66            !
     66
    6767         ENDDO
    6868      ENDDO
    69       !
     69
    7070    ENDDO
    7171    !
    7272   ENDIF
    73    !
     73
    7474  ELSE !--no aerosol LW effects
    75     !
     75
    7676    tau_aero_lw_rrtm = 1.e-15
    7777  ENDIF
    78   !
     78
    7979END SUBROUTINE AEROPT_LW_RRTM

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/dates.F90

    r5158 r5159  
    11subroutine dates_demo
    22! --------------------------------------------------------------
    3 !
     3
    44! Conseils a l'utilisateur:
    5 !
     5
    66! 1. VOUS COMPILEZ LES ENTIERS EN 32 BITS:
    77! Utilisez alors les routines
    … …  
    1717! les parametres subsequents assurant que seuls des entiers
    1818! representables en 32 bits y soient utilises.
    19 !
     19
    2020! 2. VOUS COMPILEZ LES ENTIERS EN 64 BITS:
    2121! Vous pouvez alors utiliser toutes les routines ci-dessus
    … …  
    3030! - amqhmsree_vers_dj: Conversion date gr�gorienne (en un seul r�el) > date julienne.
    3131! - dj_vers_amqhmsree: Conversion date julienne > date gr�gorienne (en un seul r�el).
    32 !
    33 ! --------------------------------------------------------------
    34 !
     32
     33! --------------------------------------------------------------
     34
    3535! D�finition des dates employ�es ci-dessous:
    36 !
     36
    3737! Date julienne DJ:
    3838!       Elle est compos�e d'un r�el.
    3939!       R1: Ce r�el cro�t de 1 tous les jours,
    4040!               et vaut 2451545.0 le 1er janvier 2000 � 12 UTC.
    41 !
     41
    4242! Date gr�gorienne "en clair" AMQHMS:
    4343!       Elle est compos�e de 5 entiers et d'un r�el.
    … …  
    8080character*200 clzue,clze,clech
    8181character *(*) cdtit
    82 !
     82
    8383!-------------------------------------------------
    8484! Date de validit�.
    8585!-------------------------------------------------
    86 !
     86
    8787zs=0.
    8888zsssss=psssss/3600.
    … …  
    9595call dj_vers_amqhms(zdj,ianv,imov,iquv,ihev,imiv,zsv) ! date gr�gorienne de validit�.
    9696if(pstati < 3600.) then
    97 !
     97
    9898!-------------------------------------------------
    9999! Ech�ance en minutes.
    100100!-------------------------------------------------
    101 !
     101
    102102    zech=pstati/60. ; clzue='mn'
    103103elseif(pstati < 259200.) then
    104 !
     104
    105105!-------------------------------------------------
    106106! Ech�ance en heures.
    107107!-------------------------------------------------
    108 !
     108
    109109    zech=pstati/3600. ; clzue='h'
    110110else
    111 !
     111
    112112!-------------------------------------------------
    113113! Ech�ance en jours.
    114114!-------------------------------------------------
    115 !
     115
    116116    zech=pstati/86400. ; clzue='j'
    117117endif
    118 !
     118
    119119! Affichage de l'echeance avec deux chiffres apres la virgule.
    120 !
     120
    121121write(clze,fmt='(f9.2)') zech
    122 !
     122
    123123! Si l'echeance est voisine d'un entier a mieux que 10**-2 pres,
    124124! on l'affiche au format entier.
    125 !
     125
    126126if(clze(len_trim(clze)-2:len_trim(clze)) == '.00') then
    127127    clze=clze(1:len_trim(clze)-3)
    … …  
    130130ilze=len_trim(clze)
    131131clech=clze(1:ilze)//clzue
    132 !
     132
    133133!-------------------------------------------------
    134134! Titre 3, de type
    135135! BASE 2000.01.15 00:00 +72H VALID 2000.01.18 15:00.
    136136!-------------------------------------------------
    137 !
     137
    138138if(imi == 0 .and. imiv == 0) then
    139 !
     139
    140140!-------------------------------------------------
    141141! Les minutes de base et validit� sont nulles.
    142142! On ne les affiche pas.
    143143!-------------------------------------------------
    144 !
     144
    145145    write(cdtit,fmt='(a,i2,a,i2.2,a,i4.4,a,i2.2,3a,i2,a,i2.2,a,i4.4,a,i2.2,a)')&
    146146    &'BASE ',kqu,'.',kmo,'.',kan,' ',ihe,'h UTC + ',clech(1:len_trim(clech))&
    147147    &,', VALID ',iquv,'.',imov,'.',ianv,' ',ihev,'h UTC'
    148148else
    149 !
     149
    150150!-------------------------------------------------
    151151! Les minutes de base ou validit� sont non nulles.
    152152! On les affiche.
    153153!-------------------------------------------------
    154 !
     154
    155155    write(cdtit,fmt='(a,i2,a,i2.2,a,i4.4,a,i2.2,a,i2.2,3a,i2,a,i2.2,a,i4.4,a,i2.2,a,i2.2,a)')&
    156156    &'BASE ',kqu,'.',kmo,'.',kan,' ',ihe,':',imi,' UTC + ',clech(1:len_trim(clech))&
    … …  
    207207character*3 cljour(0:6)
    208208data cljour/'Dim','Lun','Mar','Mer','Jeu','Ven','Sam'/
    209 !
     209
    210210!-------------------------------------------------
    211211! Date courante � la f90.
    212212!-------------------------------------------------
    213 !
     213
    214214clgol1=' '
    215215clgol2=' '
    216216clgol3=' '
    217217call date_and_time(clgol1,clgol2,clgol3,idatat)
    218 !
     218
    219219!-------------------------------------------------
    220220! clgol1 est du type "AAAAMMQQ".
    221221!-------------------------------------------------
    222 !
     222
    223223read(clgol1,fmt='(i4,2i2)') kaaaa,kmm,kqq
    224 !
     224
    225225!-------------------------------------------------
    226226! clgol2 est du type "HHMMSS.SSS".
    227227!-------------------------------------------------
    228 !
     228
    229229read(clgol2,fmt='(2i2)') khh,kmi
    230230read(clgol2(5:),fmt=*) zs
    231231kss=nint(zs)
    232232read(clgol1,fmt='(i8)') iaaaammqq
    233 !
     233
    234234!-------------------------------------------------
    235235! Jour de la semaine.
    236236!-------------------------------------------------
    237 !
     237
    238238kjs=ijoursem(iaaaammqq)
    239239cdjs=cljour(kjs)
    240 !
     240
    241241!-------------------------------------------------
    242242! Date totale.
    243243!-------------------------------------------------
    244 !
     244
    245245write(cddt,fmt='(i4.4,a,2(i2.2,a),2a,i2.2,a,i2.2,a,i2.2)') &
    246246&kaaaa,'_',kmm,'_',kqq,'_',cdjs,'_',khh,':',kmi,':',kss
    … …  
    253253! -------
    254254! 1999-08-17, J.M. Piriou.
    255 !
     255
    256256! Modifications:
    257257! --------------
    258 !
     258
    259259! --------------------------------------------------------------------------
    260260! En entree:
    … …  
    284284idate1=20000101
    285285idate2=kaaaa*10000+kmm*100+kqq
    286 !
     286
    287287!-------------------------------------------------
    288288! Nombre de jours �coul�s entre la date
    289289! d'entr�e � 0h UTC et le 1er janvier 2000 � 0h UTC.
    290290!-------------------------------------------------
    291 !
     291
    292292call ecartdj(idate1,idate2,iecart)
    293 !
     293
    294294!-------------------------------------------------
    295295! Date julienne.
    296296!-------------------------------------------------
    297 !
     297
    298298pdj=2451545.0- 0.5 +real(iecart)+real(khh)/24. &
    299299& +real(kmn)/1440.+ps/86400.
    … …  
    306306! -------
    307307! 94-10-31, J.M. Piriou.
    308 !
     308
    309309! Modifications:
    310310! --------------
    311 !
     311
    312312! --------------------------------------------------------------------------
    313313! En entree:
    … …  
    326326! En sortie:
    327327! kdat2 date finale.
    328 !
     328
    329329! --------------------------------------------------------------------------
    330330! Exemple: call DAPLUS(19940503,1,456,ires) fournira
    … …  
    373373! Cette routine est utilisable avec des entiers 32 bits ou 64 bits.
    374374! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    375 !
     375
    376376! -------------------------------------------------
    377377! Date d'arrivee au jour pres.
    … …  
    409409! si l'ecart entre les deux dates est inferieur a 2**31 secondes,
    410410! soit 68 ans!...
    411 !
     411
    412412! Au-dela de cette duree, les entiers doivent etre 64 bits.
    413413! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    … …  
    429429INTEGER(KIND=4) :: KEC
    430430character*(*) cd1,cd2
    431 !
     431
    432432! -------------------------------------------------
    433433! On lit les dates sur des entiers.
    434434! -------------------------------------------------
    435 !
     435
    436436read(cd1,fmt='(i8,3i2)') iamq1,ih1,im1,is1
    437 !
     437
    438438! -------------------------------------------------
    439439! Calculs d'ecarts et de leur partition
    440440! en multiples de 86400 et sous-multiples.
    441441! -------------------------------------------------
    442 !
     442
    443443isec=ih1*3600+im1*60+is1 ! nombre de secondes ecoulees depuis cd10h.
    444444idelta=kec+isec ! nombre de secondes entre cd10h et cd2.
    445445ireste=modulo(idelta,86400) ! nombre de secondes entre cd20h et cd2.
    446446iecjours=(idelta-ireste)/86400 ! nombre de jours entre cd10h et cd20h.
    447 !
     447
    448448! -------------------------------------------------
    449449! Date d'arrivee au jour pres.
    450450! -------------------------------------------------
    451 !
     451
    452452call daplus(iamq1,1,iecjours,iamq2)
    453 !
     453
    454454! -------------------------------------------------
    455455! Date finale a la seconde pres.
    456456! -------------------------------------------------
    457 !
     457
    458458ih2=ireste/3600
    459459ireste=ireste-3600*ih2
    … …  
    470470! -------
    471471! 1999-08-17, J.M. Piriou.
    472 !
     472
    473473! Modifications:
    474474! --------------
    475 !
     475
    476476! --------------------------------------------------------------------------
    477477! En entree:
    … …  
    485485! ps    seconde
    486486! --------------------------------------------------------------------------
    487 !
     487
    488488!-------------------------------------------------
    489489! Nombre de jours entre le 1er janvier 2000 � 0 UTC
    … …  
    508508REAL(KIND=8) :: ZFRAC
    509509zecart=pdj-2451544.5
    510 !
     510
    511511!-------------------------------------------------
    512512! Nombre entier de jours.
    513513!-------------------------------------------------
    514 !
     514
    515515zfrac=modulo(zecart, 1._8 )
    516516iecart=nint(zecart-zfrac)
    517 !
     517
    518518!-------------------------------------------------
    519519! Date gr�gorienne associ�e.
    520520!-------------------------------------------------
    521 !
     521
    522522idate1=20000101
    523523call daplusj(idate1,iecart,idate2)
    … …  
    526526kmm=mod(knouv,100)
    527527kaaaa=knouv/100
    528 !
     528
    529529!-------------------------------------------------
    530530! Calcul de des heure, minute et seconde.
    531531!-------------------------------------------------
    532 !
     532
    533533zfrac=(zecart-real(iecart))*24.
    534534khh=int(zfrac)
    … …  
    544544! -------
    545545! 2002-11, J.M. Piriou.
    546 !
     546
    547547! Modifications:
    548548! --------------
    549 !
     549
    550550! --------------------------------------------------------------------------
    551551! En entree:
    … …  
    561561REAL(KIND=8) :: ZS
    562562INTEGER(KIND=4) :: iaaaa,imm,iqq,ihh,imn
    563 !
     563
    564564!-------------------------------------------------
    565565! Conversion gr�gorien julien; cible 5 entiers et un r�el.
    566566!-------------------------------------------------
    567 !
     567
    568568call dj_vers_amqhms(pdj,iaaaa,imm,iqq,ihh,imn,zs)
    569 !
     569
    570570!-------------------------------------------------
    571571! On passe de ces 5 entiers et un r�el � un seul r�el.
    572572!-------------------------------------------------
    573 !
     573
    574574pgrer=real(iaaaa)*10000.+real(imm)*100. &
    575575& + real(iqq)+real(ihh)/100. &
    … …  
    583583! -------
    584584! 2002-11, J.M. Piriou.
    585 !
     585
    586586! Modifications:
    587587! --------------
    588 !
     588
    589589! --------------------------------------------------------------------------
    590590! En entree:
    … …  
    600600REAL(KIND=8) :: ZS,zloc
    601601INTEGER(KIND=4) :: iaaaa,imm,iqq,ihh,imn,iloc
    602 !
     602
    603603!-------------------------------------------------
    604604! On passe de cette date gr�gorienne donn�e
    605605! comme un seul r�el � 5 entiers et un r�el.
    606606!-------------------------------------------------
    607 !
     607
    608608iloc=int(pgrer)
    609609iqq=mod(iloc,100)
    … …  
    617617imn=mod(iloc,100)
    618618ihh=iloc/100
    619 !
     619
    620620!-------------------------------------------------
    621621! Conversion gr�gorien julien; cible 5 entiers et un r�el.
    622622!-------------------------------------------------
    623 !
     623
    624624call amqhms_vers_dj(iaaaa,imm,iqq,ihh,imn,zs,pdj)
    625625end
    … …  
    631631! -------
    632632! 97-01-09, J.M. Piriou.
    633 !
     633
    634634! Modifications:
    635635! --------------
    636 !
     636
    637637! --------------------------------------------------------------------------
    638638! En entree: kopt option de precision sur les dates:
    … …  
    703703! si l'ecart entre les deux dates est inferieur a 2**31 jours,
    704704! soit 5879489 ans!...
    705 !
     705
    706706! Au-dela de cette duree, les entiers doivent etre 64 bits.
    707707! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    708 !
     708
    709709! -------------------------------------------------
    710710! Ecart entre les deux dates au jour pres.
    … …  
    742742! si l'ecart entre les deux dates est inferieur a 2**31 secondes,
    743743! soit 68 ans!...
    744 !
     744
    745745! Au-dela de cette duree, les entiers doivent etre 64 bits.
    746746! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    … …  
    759759INTEGER(KIND=4) :: KECQ
    760760character*(*) cd1,cd2
    761 !
     761
    762762! -------------------------------------------------
    763763! On lit les dates sur des entiers.
    764764! -------------------------------------------------
    765 !
     765
    766766read(cd1,fmt='(i8,3i2)') iamq1,ih1,im1,is1
    767767read(cd2,fmt='(i8,3i2)') iamq2,ih2,im2,is2
    768 !
     768
    769769! -------------------------------------------------
    770770! Ecart entre les deux dates au jour pres.
    771771! -------------------------------------------------
    772 !
     772
    773773call ecartd(iamq1,iamq2,1,kecq)
    774 !
     774
    775775! -------------------------------------------------
    776776! Ecart en secondes.
    777777! -------------------------------------------------
    778 !
     778
    779779kec=kecq*86400+(ih2-ih1)*3600+(im2-im1)*60+is2-is1
    780780end
    … …  
    786786! -------
    787787! 92-05-27, J.M. Piriou.
    788 !
     788
    789789! Modifications:
    790790! --------------
    791 !
     791
    792792! --------------------------------------------------------------------------
    793793! En entree: kopt option de precision sur les dates:
    … …  
    837837INTEGER(KIND=4) :: KOPT
    838838data idebm/0,31,59,90,120,151,181,212,243,273,304,334/
    839 !
     839
    840840! --------------------------------------------------------------------------
    841841! **      1. Calcul du nb de jours separant ki2 du 1er janv 1900
    842 !
     842
    843843! *       1.1 Extraction des quantieme, mois et annee
    844844if(kopt == 1) then
    … …  
    909909! --------------------------------------------------------------------------
    910910! **      2. Calcul du nb de jours separant ii1 du 1er janv 1900
    911 !
     911
    912912! *       2.1 Extraction des quantieme, mois et annee
    913913ii1=19000101
    … …  
    952952! -------
    953953! 92-05-27, J.M. Piriou.
    954 !
     954
    955955! Modifications:
    956956! --------------
    957 !
     957
    958958! --------------------------------------------------------------------------
    959959! En entree: kopt option de precision sur les dates:
    … …  
    10041004! --------------------------------------------------------------------------
    10051005! **   On determine la date approximative d'arrivee en annees decimales
    1006 !
     1006
    10071007if(kopt == 1) then
    10081008  ! Date de type AAAAMMQQ
    … …  
    10261026! --------------------------------------------------------------------------
    10271027! **   On determine la date en clair ii2p associee a la date decimale
    1028 !
     1028
    10291029iaaaa=int(zarrdec)
    10301030zarrdec=12.*(zarrdec-real(iaaaa))
    … …  
    10351035! --------------------------------------------------------------------------
    10361036! **   On calcule le nombre de jours separant 19000101 de ii2p
    1037 !
     1037
    10381038call gregod(ii2p,1,igii2p)
    10391039imod=mod(kgre,iconv)
    … …  
    10421042! --------------------------------------------------------------------------
    10431043! **   On avance de iec jours par rapport a ii2p
    1044 !
     1044
    10451045! *       L'annee est-elle bissextile?
    10461046! Une annee est bissextile ssi elle est
    … …  
    10711071! --------------------------------------------------------------------------
    10721072! **   On met en forme la date finale
    1073 !
     1073
    10741074idat=iqq+imm*100+iaaaa*10000
    10751075if(kopt == 2) then
    … …  
    11011101! -------
    11021102! 94-10-31, J.M. Piriou.
    1103 !
     1103
    11041104! Modifications:
    11051105! --------------
    1106 !
     1106
    11071107! --------------------------------------------------------------------------
    11081108! En entree:
    … …  
    11331133! -------
    11341134! 92-05-27, J.M. Piriou.
    1135 !
     1135
    11361136! Modifications:
    11371137! --------------
    1138 !
     1138
    11391139! --------------------------------------------------------------------------
    11401140

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/eq_regions_mod.F90

    r5158 r5159  
    11module eq_regions_mod
    2 !
     2
    33!     Purpose.
    44!     --------
    … …  
    77!           equal area and small diameter.
    88!           the type.
    9 !
     9
    1010!     Background.
    1111!     -----------
    … …  
    2121!     points in an IFS gaussian grid and provide an optimal (i.e. exact)
    2222!     distribution of grid points over regions.
    23 !
     23
    2424!     The following copyright notice for the eq_regions package is included from
    2525!     the original MatLab release.
    26 !
     26
    2727!     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    2828!     + Release 1.10 2005-06-26                                                 +
    … …  
    5050!     +                                                                         +
    5151!     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    52 !
     52
    5353!     Author.
    5454!     -------
    5555!        George Mozdzynski *ECMWF*
    56 !
     56
    5757!     Modifications.
    5858!     --------------
    5959!        Original : 2006-04-15
    60 !
     60
    6161!--------------------------------------------------------------------------------
    6262
    … …  
    8585
    8686subroutine eq_regions(N)
    87 !
     87
    8888! eq_regions uses the zonal equal area sphere partitioning algorithm to partition
    8989! the surface of a sphere into N regions of equal area and small diameter.
    90 !
     90
    9191integer(kind=jpim),intent(in) :: N
    9292integer(kind=jpim) :: n_collars,j
    … …  
    100100if( N == 1 )then
    101101
    102   !
     102
    103103  ! We have only one region, which must be the whole sphere.
    104   !
     104
    105105  n_regions(1)=1
    106106  n_regions_ns=1
    … …  
    108108else
    109109
    110   !
     110
    111111  ! Given N, determine c_polar
    112112  ! the colatitude of the North polar spherical cap.
    113   !
     113
    114114  c_polar = polar_colat(N)
    115   !
     115
    116116  ! Given N, determine the ideal angle for spherical collars.
    117117  ! Based on N, this ideal angle, and c_polar,
    118118  ! determine n_collars, the number of collars between the polar caps.
    119   !
     119
    120120  n_collars = num_collars(N,c_polar,ideal_collar_angle(N))
    121121  n_regions_ns=n_collars+2
    122   !
     122
    123123  ! Given N, c_polar and n_collars, determine r_regions,
    124124  ! a list of the ideal real number of regions in each collar,
    … …  
    130130  allocate(r_regions(n_collars+2))
    131131  call ideal_region_list(N,c_polar,n_collars,r_regions)
    132   !
     132
    133133  ! Given N and r_regions, determine n_regions, a list of the natural number
    134134  ! of regions in each collar and the polar caps.
    … …  
    138138  ! n_regions[n_collars+2] is 1.
    139139  ! The sum of n_regions is N.
    140   !
     140
    141141  call round_to_naturals(N,n_collars,r_regions)
    142142  deallocate(r_regions)
    … …  
    160160
    161161function num_collars(N,c_polar,a_ideal) result(num_c)
    162 !
     162
    163163!NUM_COLLARS The number of collars between the polar caps
    164 !
     164
    165165! Given N, an ideal angle, and c_polar,
    166166! determine n_collars, the number of collars between the polar caps.
    167 !
     167
    168168integer(kind=jpim),intent(in) :: N
    169169real(kind=jprb),intent(in) :: a_ideal,c_polar
    … …  
    180180
    181181subroutine ideal_region_list(N,c_polar,n_collars,r_regions)
    182 !
     182
    183183!IDEAL_REGION_LIST The ideal real number of regions in each zone
    184 !
     184
    185185! List the ideal real number of regions in each collar, plus the polar caps.
    186 !
     186
    187187! Given N, c_polar and n_collars, determine r_regions, a list of the ideal real
    188188! number of regions in each collar, plus the polar caps.
    … …  
    191191! r_regions[n_collars+2] is 1.
    192192! The sum of r_regions is N.
    193 !
     193
    194194integer(kind=jpim),intent(in) :: N,n_collars
    195195real(kind=jprb),intent(in) :: c_polar
    … …  
    201201r_regions(1) = 1.0_jprb
    202202if( n_collars > 0 )then
    203   !
     203
    204204  ! Based on n_collars and c_polar, determine a_fitting,
    205205  ! the collar angle such that n_collars collars fit between the polar caps.
    206   !
     206
    207207  a_fitting = (pi-2.0_jprb*c_polar)/float(n_collars)
    208208  ideal_region_area = area_of_ideal_region(N)
    … …  
    218218
    219219function ideal_collar_angle(N) result(ideal)
    220 !
     220
    221221! IDEAL_COLLAR_ANGLE The ideal angle for spherical collars of an EQ partition
    222 !
     222
    223223! IDEAL_COLLAR_ANGLE(N) sets ANGLE to the ideal angle for the
    224224! spherical collars of an EQ partition of the unit sphere S^2 into N regions.
    225 !
     225
    226226integer(kind=jpim),intent(in) :: N
    227227real(kind=jprb) :: ideal
    … …  
    231231
    232232subroutine round_to_naturals(N,n_collars,r_regions)
    233 !
     233
    234234! ROUND_TO_NATURALS Round off a given list of numbers of regions
    235 !
     235
    236236! Given N and r_regions, determine n_regions, a list of the natural number
    237237! of regions in each collar and the polar caps.
    … …  
    241241! n_regions[n_collars+2] is 1.
    242242! The sum of n_regions is N.
    243 !
     243
    244244integer(kind=jpim),intent(in) :: N,n_collars
    245245real(kind=jprb),intent(in) :: r_regions(n_collars+2)
    … …  
    256256
    257257function polar_colat(N) result(polar_c)
    258 !
     258
    259259! Given N, determine the colatitude of the North polar spherical cap.
    260 !
     260
    261261integer(kind=jpim),intent(in) :: N
    262262real(kind=jprb) :: area
    … …  
    272272
    273273function area_of_ideal_region(N) result(area)
    274 !
     274
    275275! AREA_OF_IDEAL_REGION(N) sets AREA to be the area of one of N equal
    276276! area regions on S^2, that is 1/N times AREA_OF_SPHERE.
    277 !
     277
    278278integer(kind=jpim),intent(in) :: N
    279279real(kind=jprb) :: area_of_sphere
    … …  
    285285
    286286function sradius_of_cap(area) result(sradius)
    287 !
     287
    288288! SRADIUS_OF_CAP(AREA) returns the spherical radius of
    289289! an S^2 spherical cap of area AREA.
    290 !
     290
    291291real(kind=jprb),intent(in) :: area
    292292real(kind=jprb) :: sradius
    … …  
    296296
    297297function area_of_collar(a_top, a_bot) result(area)
    298 !
     298
    299299! AREA_OF_COLLAR Area of spherical collar
    300 !
     300
    301301! AREA_OF_COLLAR(A_TOP, A_BOT) sets AREA to be the area of an S^2 spherical
    302302! collar specified by A_TOP, A_BOT, where A_TOP is top (smaller) spherical radius,
    303303! A_BOT is bottom (larger) spherical radius.
    304 !
     304
    305305real(kind=jprb),intent(in) :: a_top,a_bot
    306306real(kind=jprb) area
    … …  
    310310
    311311function area_of_cap(s_cap) result(area)
    312 !
     312
    313313! AREA_OF_CAP Area of spherical cap
    314 !
     314
    315315! AREA_OF_CAP(S_CAP) sets AREA to be the area of an S^2 spherical
    316316! cap of spherical radius S_CAP.
    317 !
     317
    318318real(kind=jprb),intent(in) :: s_cap
    319319real(kind=jprb) area

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/gfl_subs.F90

    r2010 r5159  
    582582
    583583!SUBROUTINE DEACT_CLOUD_GFL  ! commente par MPL 10.12.08 (et REACT_CLOUD_GFL)
    584 !
     584
    585585!**** *DEACT_CLOUD_GFL* Deactivate prognostic cloud variables
    586 !
     586
    587587!     ------------------------------------------------------------------
    588 !
     588
    589589!INTEGER(KIND=JPIM) :: JGFL
    590590!REAL(KIND=JPRB) :: ZHOOK_HANDLE
    591 !
     591
    592592!#include "suslb.intfb.h"
    593 !
     593
    594594!IF (LHOOK) CALL DR_HOOK('GFL_SUBS:DEACT_CLOUD_GFL',0,ZHOOK_HANDLE)
    595 !
     595
    596596!IF (.NOT.L_CLD_DEACT .AND. &
    597597! & (YL%LACTIVE .OR. YI%LACTIVE .OR. &
    … …  
    611611!    IF (YA%LGP) YGFL%NUMGPFLDS=YGFL%NUMGPFLDS-1
    612612!    IF (YCPF%LGP) YGFL%NUMGPFLDS=YGFL%NUMGPFLDS-1
    613 !
     613
    614614!    IF (YL%LT5) YGFL%NUMFLDS5=YGFL%NUMFLDS5-1
    615615!    IF (YI%LT5) YGFL%NUMFLDS5=YGFL%NUMFLDS5-1
    … …  
    618618!    IF (YA%LT5) YGFL%NUMFLDS5=YGFL%NUMFLDS5-1
    619619!    IF (YCPF%LT5) YGFL%NUMFLDS5=YGFL%NUMFLDS5-1
    620 !
     620
    621621!    CALL FALSIFY_GFLC(YL)
    622622!    CALL FALSIFY_GFLC(YI)
    … …  
    643643! ENDDO
    644644! CALL SUSLB
    645 !
     645
    646646! L_CLD_DEACT=.TRUE.
    647647! WRITE(NULOUT,*)' CLOUD FIELDS DE-ACTIVATAD, YGFL%NUMGPFLDS=', &
    648648! & YGFL%NUMGPFLDS,' YGFL%NUMFLDS_SL1=', YGFL%NUMFLDS_SL1
    649649!ENDIF
    650 !
     650
    651651!IF (LHOOK) CALL DR_HOOK('GFL_SUBS:DEACT_CLOUD_GFL',1,ZHOOK_HANDLE)
    652 !
     652
    653653!END SUBROUTINE DEACT_CLOUD_GFL
    654 !
     654
    655655!!=========================================================================
    656 !
     656
    657657!SUBROUTINE REACT_CLOUD_GFL
    658658!!**** *REACT_CLOUD_GFL* Reactivate prognostic cloud variables
    659 !
     659
    660660!INTEGER(KIND=JPIM) :: JGFL
    661661!REAL(KIND=JPRB) :: ZHOOK_HANDLE
    … …  
    664664!!     ------------------------------------------------------------------
    665665!IF (LHOOK) CALL DR_HOOK('GFL_SUBS:REACT_CLOUD_GFL',0,ZHOOK_HANDLE)
    666 !
     666
    667667!IF (L_CLD_DEACT) THEN
    668668!  LLGPL = YL%LGP
    … …  
    673673!  CALL COPY_GFLC_GFLC(YI,YI_SAVE)
    674674!  CALL COPY_GFLC_GFLC(YA,YA_SAVE)
    675 !
     675
    676676!  IF (.NOT. LLGPL .AND. YL%LGP) YGFL%NUMGPFLDS=YGFL%NUMGPFLDS+1
    677677!  IF (.NOT. LLGPI .AND. YI%LGP) YGFL%NUMGPFLDS=YGFL%NUMGPFLDS+1
    678678!  IF (.NOT. LLGPA .AND. YA%LGP) YGFL%NUMGPFLDS=YGFL%NUMGPFLDS+1
    679 !
     679
    680680!  YGFL%NUMFLDS_SL1 = 0
    681681!  DO JGFL=1,YGFL%NUMFLDS
    … …  
    688688!  ENDDO
    689689!  CALL SUSLB
    690 !
     690
    691691!  L_CLD_DEACT=.FALSE.
    692692!  WRITE(NULOUT,*)' CLOUD FIELDS RE-ACTIVATAD, YGFL%NUMGPFLDS=', &
    693693!  & YGFL%NUMGPFLDS,' YGFL%NUMFLDS_SL1=', YGFL%NUMFLDS_SL1
    694694!ENDIF
    695 !
     695
    696696!IF (LHOOK) CALL DR_HOOK('GFL_SUBS:REACT_CLOUD_GFL',1,ZHOOK_HANDLE)
    697 !
     697
    698698!!     ------------------------------------------------------------------
    699699!END SUBROUTINE REACT_CLOUD_GFL

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/gppref.F90

    r1990 r5159  
    2121!                              PRESH(KPROMA,0:KFLEV) - HALF LEVEL PRESSURE
    2222!                              PRESF(KPROMA,KFLEV)   - FULL LEVEL PRESSURE
    23 !
     23
    2424!        Implicit arguments :  NONE.
    2525!        --------------------
    … …  
    105105! assumption that the top level input for pressure is 0 hPa.
    106106! This restriction is only necessary in the case of use of NDLNPR=1.
    107 !
     107
    108108! LVERTFE : .T./.F. Finite element/conventional vertical discretisation.
    109109! NDLNPR  : NDLNPR=0: conventional formulation of delta, i.e. ln(P(l)/P(l-1)).
    110110!           NDLNPR=1: formulation of delta used in non hydrostatic model,
    111111! LAPRXPK : way of computing full-levels pressures in primitive equation
    112 !
     112
    113113LVERTFE=.TRUE.    !!!!! A REVOIR (MPL) comment faut-il vraiment calculer PRESF ?
    114114

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/lwu.F90

    r5154 r5159  
    1 !
     1
    22! $Id$
    3 !
     3
    44SUBROUTINE LWU &
    55        & (KIDIA, KFDIA, KLON, KLEV, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/namphy0.h

    r1990 r5159  
    3636!     For ACCVIMPGY
    3737  &,ALFX,TCTC,TVFC,GAMAP1,RKDN,VVN,VVX,FENTRT,HCMIN,FQLIC,FNEBC,FEVAPC &
    38 !
     38
    3939  &,RDPHIC,GWBFAUT,RWBF1,RWBF2,RAUITN,RAUITX,RAUIUSTE &
    4040  &,RSMDNEBX,RSMDTX,NSMTPA,NSMTPB

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/parkind1.F90

    r1990 r5159  
    11MODULE PARKIND1
    2 !
     2
    33!     *** Define usual kinds for strong typing ***
    4 !
     4
    55IMPLICIT NONE
    66SAVE
    7 !
     7
    88!     Integer Kinds
    99!     -------------
    10 !
     10
    1111INTEGER, PARAMETER :: JPIT = SELECTED_INT_KIND(2)
    1212INTEGER, PARAMETER :: JPIS = SELECTED_INT_KIND(4)
    … …  
    2222#endif
    2323
    24 !
     24
    2525!     Real Kinds
    2626!     ----------
    27 !
     27
    2828INTEGER, PARAMETER :: JPRT = SELECTED_REAL_KIND(2,1)
    2929INTEGER, PARAMETER :: JPRS = SELECTED_REAL_KIND(4,2)
    3030INTEGER, PARAMETER :: JPRM = SELECTED_REAL_KIND(6,37)
    3131INTEGER, PARAMETER :: JPRB = SELECTED_REAL_KIND(13,300)
    32 !
     32
    3333END MODULE PARKIND1

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/parkind2.F90

    r1990 r5159  
    11MODULE PARKIND2
    2 !
     2
    33!     *** Define huge kinds for strong typing ***
    4 !
     4
    55IMPLICIT NONE
    66SAVE
    7 !
     7
    88!     Integer Kinds
    99!     -------------
    10 !
     10
    1111INTEGER, PARAMETER :: JPIH = SELECTED_INT_KIND(18)
    12 !
     12
    1313!     Real Kinds
    1414!     ----------
    15 !
     15
    1616#ifdef REALHUGE
    1717INTEGER, PARAMETER :: JPRH = SELECTED_REAL_KIND(31,291)
    … …  
    1919INTEGER, PARAMETER :: JPRH = SELECTED_REAL_KIND(13,300)
    2020#endif
    21 !
     21
    2222END MODULE PARKIND2

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/radlsw.F90

    r5154 r5159  
    10481048
    10491049!     ------------------------------------------------------------------
    1050 !
     1050
    10511051!*         2.7    DIFFUSIVITY FACTOR OR SATELLITE VIEWING ANGLE
    10521052!                 ---------------------------------------------

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/read_rsun_rrtm.F90

    r5154 r5159  
    33!****************************************************************************************
    44! This routine will read the solar constant fraction per band
    5 !
     5
    66! Olivier Boucher with inputs from Marion Marchand
    77!****************************************************************************************

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/readaerosol_optic_rrtm.F90

    r5154 r5159  
    11! $Id: readaerosol_optic_rrtm.F90 4124 2022-04-08 14:47:04Z dcugnet $
    2 !
     2
    33SUBROUTINE readaerosol_optic_rrtm(debut, aerosol_couple, ok_alw, ok_volcan, &
    44     flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, &
    … …  
    9999  !   
    100100  !****************************************************************************************
    101   !
    102   !
     101
     102
    103103  IF (aerosol_couple) THEN   !--we get aerosols from tr_seri array from INCA
    104      !
     104
    105105     !--copy fields from INCA tr_seri
    106106     !--convert to ug m-3 unit for consistency with offline fields
    107      !
     107
    108108     itr = 0
    109109     DO iq = 1,nqtot
    … …  
    142142     nitrcoarse(:,:)   =   tr_seri(:,:,id_CSNO3M)                        *zrho(:,:)*1.e9  ! CSNO3M
    143143     nitrinscoarse(:,:)=   tr_seri(:,:,id_CINO3M)                        *zrho(:,:)*1.e9  ! CINO3M
    144      !
     144
    145145     bcsol_pi(:,:)        =   0.0 ! ASBCM pre-ind
    146146     pomsol_pi(:,:)       =   0.0 ! ASPOMM pre-ind
    … …  
    156156     nitrcoarse_pi(:,:)   =   0.0 ! CSNO3M pre-ind
    157157     nitrinscoarse_pi(:,:)=   0.0 ! CINO3M
    158      !
     158
    159159  ELSE !--not aerosol_couple
    160      !
     160
    161161     ! Read and interpolate sulfate
    162162     IF ( flag_aerosol .EQ. 1 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN
    … …  
    219219        loaddust=0.
    220220     ENDIF
    221      !
     221
    222222     ! Read and interpolate asno3m, csno3m, cino3m
    223223     IF (flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN
    … …  
    237237        loadno3(:)=0.0
    238238     ENDIF
    239      !
     239
    240240     ! CSSO4M is set to 0 as not reliable
    241241     sulfcoarse(:,:)      =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA)
    … …  
    244244  ENDIF !--not aerosol_couple
    245245
    246   !
     246
    247247  ! Store all aerosols in one variable
    248   !
     248
    249249  m_allaer(:,:,id_ASBCM_phy)  = bcsol(:,:)        ! ASBCM
    250250  m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:)       ! ASPOMM
    … …  
    278278  m_allaer_pi(:,:,id_STRAT_phy)  = 0.0
    279279
    280   !
     280
    281281  ! Calculate the total mass of all soluble aersosols
    282282  ! to be revisited for AR6
    … …  
    286286  !****************************************************************************************
    287287  ! 2) Calculate optical properties for the aerosols
    288   !
     288
    289289  !****************************************************************************************
    290290  DO k = 1, klev

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/readaerosolstrato1_rrtm.F90

    r5133 r5159  
    1 !
     1
    22! $Id: readaerosolstrato1_rrtm.F90 2526 2016-05-26 22:13:40Z oboucher $
    33!
    … …  
    5757    DATA cg_sw_strat   /0.6997170, 0.6810035, 0.7403592, 0.7562674, 0.6676504, 0.3478689/
    5858    DATA piz_sw_strat  /0.9999998, 0.9999998, 1.000000000, 0.9999958, 0.9977155, 0.4510679/
    59 !
     59
    6060!--diagnostics AOD in the SW
    6161! alpha_sw_strat_wave is *not* normalised by the 550 nm extinction coefficient
    6262    REAL, DIMENSION(nwave_sw) :: alpha_sw_strat_wave
    6363    DATA alpha_sw_strat_wave/3.708007,4.125824,4.136584,3.887478,3.507738/
    64 !
     64
    6565!--diagnostics AOD in the LW at 10 um (not normalised by the 550 nm ext coefficient
    6666    REAL :: alpha_lw_strat_wave(nwave_lw)
    6767    DATA alpha_lw_strat_wave/0.2746812/
    68 !
     68
    6969    REAL, DIMENSION(nbands_lw_rrtm) :: alpha_lw_abs_rrtm
    7070    DATA alpha_lw_abs_rrtm/   8.8340312E-02, 6.9856711E-02, 6.2652975E-02, 5.7188231E-02, &
    … …  
    178178   
    179179    IF (is_mpi_root.AND.is_omp_root) THEN
    180 !
     180
    181181    DEALLOCATE(tauaerstrat)
    182182    DEALLOCATE(tauaerstrat_mois)
    183183    DEALLOCATE(tauaerstrat_mois_glo)
    184 !
     184
    185185    ENDIF !--is_mpi_root and is_omp_root
    186186

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/readaerosolstrato2_rrtm.F90

    r5154 r5159  
    1 !
     1
    22! $Id: readaerosolstrato2_rrtm.F90 2526 2016-05-26 22:13:40Z oboucher $
    3 !
     3
    44SUBROUTINE readaerosolstrato2_rrtm(debut, ok_volcan)
    55
    … …  
    341341
    342342    IF (.NOT. ok_volcan) THEN
    343 !
     343
    344344!--this is the default case
    345345!--stratospheric aerosols are added to both index 2 and 1 for double radiation calls
    … …  
    367367    ENDWHERE
    368368    ENDDO
    369 !
     369
    370370    ELSE
    371 !
     371
    372372!--this is the VOLMIP case
    373373!--stratospheric aerosols are only added to index 2 in this case
    … …  
    410410      ENDWHERE
    411411    ENDDO
    412 !
     412
    413413    ELSE
    414 !
     414
    415415!--this is the VOLMIP case
    416416    DO band=1, NLW
    … …  
    418418!--and we copy index 2 in index 1 because we want the same dust aerosol LW properties as above
    419419      tau_aero_lw_rrtm(:,:,1,band)  = tau_aero_lw_rrtm(:,:,2,band)
    420 !
     420
    421421      WHERE (stratomask.GT.0.999999)
    422422!--stratospheric aerosols are only added to index 2

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/recmwf_aero.F90

    r5154 r5159  
    1 !
     1
    22! $Id: recmwf_aero.F90 4875 2024-03-26 10:29:06Z lguez $
    3 !
     3
    44!OPTIONS XOPT(NOEVAL)
    55SUBROUTINE RECMWF_AERO (KST, KEND, KPROMA, KTDIA , KLEV,&
    … …  
    464464
    465465  !*         4.1     CALL TO ACTUAL RADIATION SCHEME
    466   !
     466
    467467  !----now we make multiple calls to the radiation according to which
    468468  !----aerosol flags are on

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/rrtm_ecrt_140gp.F90

    r5154 r5159  
    1 !
     1
    22! $Id$
    3 !
     3
    44!****************** SUBROUTINE RRTM_ECRT_140GP **************************
    55

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/sdl_module.F90

    r1990 r5159  
    4343!CHARACTER(LEN=*), PARAMETER :: CLNECMSG = '*** Calling NEC traceback ***'
    4444!#endif
    45 !
     45
    4646!IF (PRESENT(KTID)) THEN
    4747!  ITID = KTID
    … …  
    4949!  ITID = OML_MY_THREAD()
    5050!ENDIF
    51 !
     51
    5252!IF (LHOOK) THEN
    5353!  IPRINT_OPTION = 2
    … …  
    5555!  CALL C_DRHOOK_PRINT(0, ITID, IPRINT_OPTION, ILEVEL) ! from drhook.c
    5656!ENDIF
    57 !
     57
    5858!#ifdef VPP
    5959!  CALL ERRTRA
    … …  
    117117!MPL 4.12.08
    118118!#ifdef VPP
    119 !
     119
    120120!CALL VPP_ABORT()
    121 !
     121
    122122!#else
    123 !
     123
    124124!IRETURN_CODE=1
    125125!CALL MPI_ABORT(KCOMM,IRETURN_CODE,IERROR)

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/srtm_cmbgb16.F90

    r1990 r5159  
    11SUBROUTINE SRTM_CMBGB16
    22
    3 !
     3
    44!  Original version:       Michael J. Iacono; July, 1998
    55!  Revision for RRTM_SW:   Michael J. Iacono; November, 2002
    66!  Revision for RRTMG_SW:  Michael J. Iacono; December, 2003
    7 !
     7
    88!  The subroutines CMBGB16->CMBGB29 input the absorption coefficient
    99!  data for each band, which are defined for 16 g-points and 14 spectral
    … …  
    1212!  function data in array SFLUXREF are combined without weighting.  All
    1313!  g-point reduced data are put into new arrays for use in RRTMG_SW.
    14 !
     14
    1515!  BAND 16:  2600-3250 cm-1 (low key- H2O,CH4; high key - CH4)
    16 !
     16
    1717!-----------------------------------------------------------------------
    1818

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/srtm_srtm_224gp.F90

    r5154 r5159  
    1 !
     1
    22! $Id$
    3 !
     3
    44SUBROUTINE SRTM_SRTM_224GP &
    55        & (KIDIA, KFDIA, KLON, KLEV, KSW, KOVLP, &

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/su_aerop.F90

    r5158 r5159  
    7171! For sea-salt (_SS), 3 bins are considered      (0.03, 0.50, 5.0, 20.)
    7272! For desert dust (_DD), 3 bins are considered     (0.03, 0.55, 0.9, 20.)
    73 !
     73
    7474! IF BIN LIMITS ARE CHANGED, MAKE SURE THAT THE RELEVANT SEDIMENTATION SPEEDS ARE
    7575! RECOMPUTED ACCORDINGLY

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/su_aerp.F90

    r5158 r5159  
    107107!RVDPOCE = (/   0.1_JPRB,   1.2_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB &
    108108!          &,   0.1_JPRB,   1.2_JPRB,   1.2_JPRB,   1.2_JPRB,   1.5_JPRB,   1.5_JPRB /)
    109 !
     109
    110110!RVDPSIC = (/   0.1_JPRB,   1.2_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB &
    111111!          &,   0.1_JPRB,   1.2_JPRB,   1.2_JPRB,   1.2_JPRB,   1.5_JPRB,   1.5_JPRB /)
    112 !
     112
    113113!RVDPLND = (/   0.1_JPRB,   1.2_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB &
    114114!          &,   0.1_JPRB,   1.2_JPRB,   1.2_JPRB,   1.2_JPRB,   1.5_JPRB,   1.5_JPRB /)
    115 !
     115
    116116!RVDPLIC = (/   0.1_JPRB,   1.2_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB,   0.1_JPRB &
    117117!          &,   0.1_JPRB,   1.2_JPRB,   1.2_JPRB,   1.2_JPRB,   1.5_JPRB,   1.5_JPRB /)

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/suclopn.F90

    r1990 r5159  
    10021002!    RASWCE(JNU)=ZASWCE14(JNU)
    10031003!    RASWCF(JNU)=ZASWCF14(JNU)*1.E-03_JPRB
    1004 !
     1004
    10051005!    REBCUA(JNU)=ZEBCUA14(JNU)
    10061006!    REBCUB(JNU)=ZEBCUB14(JNU)
    … …  
    10091009!    REBCUE(JNU)=ZEBCUE14(JNU)
    10101010!    REBCUF(JNU)=ZEBCUF14(JNU)
    1011 !
     1011
    10121012!    RYFWCA(JNU)=ZYFWCA14(JNU)
    10131013!    RYFWCB(JNU)=ZYFWCB14(JNU)
    … …  
    10161016!    RYFWCE(JNU)=ZYFWCE14(JNU)
    10171017!    RYFWCF(JNU)=ZYFWCF14(JNU)
    1018 !
     1018
    10191019!    RSUSHE(JNU)=ZSUSHE14(JNU)*1.E-02_JPRB
    10201020!    RSUSHF(JNU)=ZSUSHF14(JNU)*1.E-02_JPRB
    … …  
    10531053!!    RFUDD2(JNU)=ZFUDD214(JNU)
    10541054!!    RFUDD3(JNU)=ZFUDD314(JNU)
    1055 !
     1055
    10561056!    PRINT *,'SUCLOPN: 14-SPECTRAL INTERVALS --> RRTM_SW'     
    10571057!  ENDDO

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/suecrad.F90

    r5158 r5159  
    1 !
     1
    22! $Id: suecrad.F90 4251 2022-09-20 00:22:43Z fhourdin $
    3 !
     3
    44SUBROUTINE SUECRAD (KULOUT, KLEV, PETAH)
    55

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/sugfl.F90

    r1990 r5159  
    104104
    105105!      1.   CASE LFPART2=F
    106 !
     106
    107107!      1.1  Initial settings.
    108108

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/suphec.F90

    r5154 r5159  
    129129
    130130IF (LHOOK) CALL DR_HOOK('SUPHEC',0,ZHOOK_HANDLE)
    131 !
     131
    132132  IF (OK_BAD_ECMWF_THERMO) THEN
    133 !
     133
    134134     ! Modify constants defined in suphel.F90 and set RVTMP2 to 0.
    135135     ! CALL GSTATS(1811,0) ! MPL 28.11.08
    … …  
    169169     ! Keep constants defined in suphel.F90
    170170     RTICE=RTT-23._JPRB
    171 !
     171
    172172  ENDIF  ! (OK_BAD_ECMWF_THERMO)
    173173

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/suphy.F90

    r1990 r5159  
    3434!     SUPHYFL
    3535!     SUHLPH
    36 !
     36
    3737!     Reference.
    3838!     ----------
    … …  
    9999print *,'---- SUPHY: avant SUPHMF'
    100100CALL SUPHMF(KULOUT)
    101 !
     101
    102102print *,'---- SUPHY: avant SUGFL'
    103103!SUGFL: Set up unified_treatment grid-point fields
    … …  
    117117! Commente par MPL 20.11.08
    118118!CALL SUHLPH(KULOUT)   
    119 !
     119
    120120!     ------------------------------------------------------------------
    121121

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/suphy0.F90

    r1990 r5159  
    341341RWBF1=300._JPRB
    342342RWBF2=4._JPRB
    343 !
     343
    344344RAUITN=233.15_JPRB
    345345RAUITX=263.15_JPRB

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/surdi.F90

    r2626 r5159  
    1 !
     1
    22! $Id$
    3 !
     3
    44SUBROUTINE SURDI
    55

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/surhcri.F90

    r1990 r5159  
    22      SUBROUTINE SURHCRI(KULOUT)
    33!-----------------------------------------------------------------------
    4 !
     4
    55!**** *SURHCRI * - COMPUTATION OF THE CRTITICAL RELATIVE HUMIDITY
    66!                  PROFILE FOR SMITH'S CONDENSATION SCHEME.
    7 !
     7
    88!**   Interface.
    99!     ----------
    1010!        *CALL* *SURHCRI*
    11 !
     11
    1212!-----------------------------------------------------------------------
    13 !
     13
    1414! -   ARGUMENTS D'ENTREE./INPUT ARGUMENTS.
    1515!     ------------------------------------
    16 !
     16
    1717!-----------------------------------------------------------------------
    18 !
     18
    1919! -   ARGUMENTS IMPLICITES.
    2020!     ---------------------
    21 !
     21
    2222! COMMON /YOMPHY/
    2323! COMMON /YOMPHY0/
    24 !
     24
    2525!*
    2626!-----------------------------------------------------------------------
    27 !
     27
    2828!     Auteur.
    2929!     -------
    3030!         05-03, Luc Gerard (from Ph. Lopez acrhcri)
    31 !
     31
    3232!     Modifications.
    3333!     --------------
    3434!         06-10, nettoyage - R. Brozkova
    3535!-----------------------------------------------------------------------
    36 !
     36
    3737USE PARKIND1  ,ONLY : JPIM     ,JPRB
    3838USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
    39 !
     39
    4040USE YOMPHY0   , ONLY : RHCRIT1, RHCRIT2, RETAMIN, GRHCMOD, RHCRI ,NRHCRI
    4141USE YOMDIM    , ONLY : NFLEVG

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/susrtm.F90

    r1990 r5159  
    4040! minimize the effect on the resulting fluxes and cooling rates, and
    4141! caution should be used if the mapping is modified.
    42 !
     42
    4343! JPGPT   The total number of new g-points (NGPT)
    4444! NGC     The number of new g-points in each band

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/yoeaeratm.F90

    r2010 r5159  
    2727! RMFMIN     : minimum mass flux for convective aerosol transport
    2828! RMASSE     : Molar mass: N.B.: either g/mol or Avogadro number
    29 !
     29
    3030! REPSCAER   : security on aerosol concentration: always >= 1.E-15
    31 !
     31
    3232! LAERCLIMG  : .T. to start prognostic aerosols with geographical monthly
    3333!                  mean climatology

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/yoewcou.F90

    r2010 r5159  
    3939!     *RNORTW*   REAL       NORTH BOUNDARY OF THE WAVE MODEL.
    4040!     *RDEGREW*  REAL       RESOLUTION OF THE WAVE MODEL (DEGREES).
    41 !
     41
    4242!     *MASK_WAVE_IN*  INTEGER  COMMS MASK FOR INPUT TO WAVE MODEL
    4343!     *MASK_WAVE_OUT* INTEGER  COMMS MASK FOR OUTPUT FROM WAVE MODEL
    44 !
     44
    4545!     *LWVIN_MASK_NOT_SET* LOGICAL indicates whether mask_wave_in
    4646!                           has been updated on the first call to the
    … …  
    6464!     *MWVIN_SENDIND* INTEGER global indexes of data on remote tasks that
    6565!                           the local task needs
    66 !
     66
    6767!     *MWVIN_RECVOFF* INTEGER nproc sized array containing offsets into
    6868!                           the MWVIN_RECVBUF array

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/yomct0.F90

    r2010 r5159  
    463463LOGICAL ::  LPC_OLD
    464464LOGICAL ::  LPC_NESC
    465 !
     465
    466466! * FORCING
    467467LOGICAL ::  LSFORC

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/yomgrb.F90

    r5158 r5159  
    280280! NGRBCO2B         - 210068 CO2 - biosphere flux
    281281! NGRBCO2A         - 210069 CO2 - anthropogenic emissions
    282 !
     282
    283283!---------------------------------------------------
    284284! NGRBGRG(JPGRG)   - 210121 GRG1: Nitrogen dioxide

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/yomphy0.F90

    r2010 r5159  
    352352!    TFVS     : VITESSE DE CHUTE DES PRECIPITATIONS SOLIDES.
    353353!    GRHCMOD  : MODULATION IN CRITICAL RELATIVE HUMIDITY COMPUTATION.
    354 !
     354
    355355! Pseudo prognostic TKE scheme
    356356!    NUPTKE   : TUNABLE VALUE FOR PSEUDO TKE SCHEME FOLLOWING
    … …  
    374374
    375375!   GCVALMX   : MAXIMUM ACCEPTABLE VALUE FOR TOTAL MESH FRACTION
    376 !
     376
    377377!              Ascent properties
    378378!      ECMNPI : ECMNP for ice, the original ECMNP being kept for liquid.
    379379!      GFRIC  : INVERSE OF CHARACTERISTIC TIME for ICE CONDENSATION in ud.
    380 !
     380
    381381!              Squeezing:
    382382!   GCVSQDN   : threshold value of sigma_d*q_cd*dp
    383383!   GCVSQDR   : fraction of the max to consider for squeezing
    384384!   GCVSQDCX  : maximum acceptable compression (<1)
    385 !
     385
    386386!              Downdraught:
    387387!   GDDWPF    : Influence of rain fall velocity on downdraught
    … …  
    389389!   GDDBETA   : DOWNDRAUGHT EXPLICIT DETRAINMENT COEFFICIENT
    390390!   TENTRD    : DOWNDRAUGHT ENTRAINMENT RATE (S^2/M^2)
    391 !
     391
    392392!              Intensive Precipitation:
    393393!   GRRMINA   : MINIMUM REALISTIC PRECIPITATING MESH FRACTION
    … …  
    671671!     For ALARO-0 :
    672672!     ------------------------------------------------------------------
    673 !
     673
    674674! RDPHIC   : REFERENCE GEOPOTENTIAL FOR CLOUDINESS ADJUSTMENT.
    675675! GWBFAUT  : GAIN FOR THE WEGENER BERGERON FINDEISEN PROCESS IN ACAUTO
    … …  
    677677! RWBF2    : SECOND TUNING CONSTANT FOR BERGERON FINDEISEN PROCESS
    678678!               IN ACPLUIE_PROG
    679 !
     679
    680680! RAUITN   : TEMPERATURE LEVELS FOR RQICRMIN
    681681! RAUITX   : TEMPERATURE LEVELS FOR RQICRMAX
    … …  
    687687! NSMTPA   : NUMBER OF LEVELS BELOW Tt LEVEL FOR LSMTPS SMOOTHING
    688688! NSMTPB   : NUMBER OF LEVELS ABOVE Tt LEVEL FOR LSMTPS SMOOTHING
    689 !
     689
    690690! ------------------------------------------------------------------
    691 !
     691
    692692REAL(KIND=JPRB) :: RDPHIC
    693693REAL(KIND=JPRB) :: GWBFAUT

  • LMDZ6/branches/Amaury_dev/libf/phylmd/rrtm/yomphy3.F90

    r2010 r5159  
    8888!               : AT THE UPPER CASE OF PADE FUNCTIONS FOR GASES.
    8989! Parameters for cloud model:
    90 !
     90
    9191!   Notations:
    9292!     g      - asymmetry factor            (unscaled)
    … …  
    9898!     iwc    - ice water content
    9999!     lwc    - liquid water content
    100 !
     100
    101101!   First index of FCM arrays (FCM = Fitting parameters for Cloud Model)
    102102!   denotes spectral band:
    103103!     1      - solar
    104104!     2      - thermal
    105 !
     105
    106106!   FCM_DEL_A(2)    : Critical value of delta0 for computation of c_abs.
    107107!   FCM_DEL_D(2)    : Critical value of delta0 for computation of c_scat.
Note: See TracChangeset for help on using the changeset viewer.