Ignore:
Timestamp:
Jan 28, 2016, 5:02:13 PM (9 years ago)
Author:
Laurent Fairhead
Message:

Merged trunk changes r2396:2434 into testing branch

Location:
LMDZ5/branches/testing
Files:
7 deleted
81 edited
38 copied

Legend:

Unmodified
Added
Removed

  • LMDZ5/branches/testing

  • LMDZ5/branches/testing/libf/dyn3dpar/gcm.F

    r2408 r2435  
    3030
    3131#ifdef CPP_PHYS
    32   USE iniphysiq_mod, ONLY: iniphysiq
     32      USE iniphysiq_mod, ONLY: iniphysiq
    3333#endif
    3434      IMPLICIT NONE

  • LMDZ5/branches/testing/libf/phy_common/mod_phys_lmdz_mpi_data.F90

    • Property svn:keywords changed from Author Date Id Revision to Id
    r2408 r2435  
    11!
    2 !$Header$
     2!$Id$
    33!
    44MODULE mod_phys_lmdz_mpi_data
    … …  
    4141 
    4242 
    43   LOGICAL,SAVE :: is_north_pole
    44   LOGICAL,SAVE :: is_south_pole
     43!  LOGICAL,SAVE :: is_north_pole
     44!  LOGICAL,SAVE :: is_south_pole
     45  LOGICAL,SAVE :: is_north_pole_dyn
     46  LOGICAL,SAVE :: is_south_pole_dyn
    4547  INTEGER,SAVE :: COMM_LMDZ_PHY
    4648  INTEGER,SAVE :: MPI_REAL_LMDZ   ! MPI_REAL8
    … …  
    109111   
    110112    IF (mpi_rank == 0) THEN
    111       is_north_pole = .TRUE.
    112     ELSE
    113       is_north_pole = .FALSE.
     113      is_north_pole_dyn = .TRUE.
     114    ELSE
     115      is_north_pole_dyn = .FALSE.
    114116    ENDIF
    115117   
    116118    IF (mpi_rank == mpi_size-1) THEN
    117       is_south_pole = .TRUE.
    118     ELSE
    119       is_south_pole = .FALSE.
     119      is_south_pole_dyn = .TRUE.
     120    ELSE
     121      is_south_pole_dyn = .FALSE.
    120122    ENDIF
    121123   
    … …  
    217219    WRITE(lunout,*) 'mpi_master =', mpi_master
    218220    WRITE(lunout,*) 'is_mpi_root =', is_mpi_root
    219     WRITE(lunout,*) 'is_north_pole =', is_north_pole
    220     WRITE(lunout,*) 'is_south_pole =', is_south_pole
     221    WRITE(lunout,*) 'is_north_pole =', is_north_pole_dyn
     222    WRITE(lunout,*) 'is_south_pole =', is_south_pole_dyn
    221223    WRITE(lunout,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
    222224 

  • LMDZ5/branches/testing/libf/phy_common/mod_phys_lmdz_mpi_transfert.F90

    • Property svn:keywords changed from Author Date Id Revision to Id
    r2408 r2435  
    11!
    2 !$Header$
     2!$Id$
    33!
    44MODULE mod_phys_lmdz_mpi_transfert
    … …  
    16931693   
    16941694    offset=ii_begin
    1695     IF (is_north_pole) Offset=nbp_lon
     1695    IF (is_north_pole_dyn) Offset=nbp_lon
    16961696   
    16971697   
    … …  
    17031703   
    17041704   
    1705     IF (is_north_pole) THEN
     1705    IF (is_north_pole_dyn) THEN
    17061706      DO i=1,dimsize
    17071707        DO ij=1,nbp_lon
    … …  
    17111711    ENDIF
    17121712   
    1713     IF (is_south_pole) THEN
     1713    IF (is_south_pole_dyn) THEN
    17141714      DO i=1,dimsize
    17151715        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
    … …  
    17371737   
    17381738    offset=ii_begin
    1739     IF (is_north_pole) Offset=nbp_lon
     1739    IF (is_north_pole_dyn) Offset=nbp_lon
    17401740   
    17411741   
    … …  
    17471747   
    17481748   
    1749     IF (is_north_pole) THEN
     1749    IF (is_north_pole_dyn) THEN
    17501750      DO i=1,dimsize
    17511751        DO ij=1,nbp_lon
    … …  
    17551755    ENDIF
    17561756   
    1757     IF (is_south_pole) THEN
     1757    IF (is_south_pole_dyn) THEN
    17581758      DO i=1,dimsize
    17591759        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
    … …  
    17821782   
    17831783    offset=ii_begin
    1784     IF (is_north_pole) Offset=nbp_lon
     1784    IF (is_north_pole_dyn) Offset=nbp_lon
    17851785   
    17861786   
    … …  
    17921792   
    17931793   
    1794     IF (is_north_pole) THEN
     1794    IF (is_north_pole_dyn) THEN
    17951795      DO i=1,dimsize
    17961796        DO ij=1,nbp_lon
    … …  
    18001800    ENDIF
    18011801   
    1802     IF (is_south_pole) THEN
     1802    IF (is_south_pole_dyn) THEN
    18031803      DO i=1,dimsize
    18041804        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
    … …  
    18241824
    18251825    offset=ii_begin
    1826     IF (is_north_pole) offset=nbp_lon
     1826    IF (is_north_pole_dyn) offset=nbp_lon
    18271827
    18281828    DO i=1,dimsize
    … …  
    18321832    ENDDO
    18331833
    1834     IF (is_north_pole) THEN
     1834    IF (is_north_pole_dyn) THEN
    18351835      DO i=1,dimsize
    18361836        VarOut(1,i)=VarIn(1,i)
    … …  
    18541854
    18551855    offset=ii_begin
    1856     IF (is_north_pole) offset=nbp_lon
     1856    IF (is_north_pole_dyn) offset=nbp_lon
    18571857
    18581858    DO i=1,dimsize
    … …  
    18621862    ENDDO
    18631863
    1864     IF (is_north_pole) THEN
     1864    IF (is_north_pole_dyn) THEN
    18651865      DO i=1,dimsize
    18661866         VarOut(1,i)=VarIn(1,i)
    … …  
    18831883
    18841884    offset=ii_begin
    1885     IF (is_north_pole) offset=nbp_lon
     1885    IF (is_north_pole_dyn) offset=nbp_lon
    18861886
    18871887    DO i=1,dimsize
    … …  
    18911891    ENDDO
    18921892
    1893     IF (is_north_pole) THEN
     1893    IF (is_north_pole_dyn) THEN
    18941894      DO i=1,dimsize
    18951895        VarOut(1,i)=VarIn(1,i)

  • LMDZ5/branches/testing/libf/phy_common/mod_phys_lmdz_omp_data.F90

    r2408 r2435  
    88  LOGICAL,SAVE :: is_omp_root
    99  LOGICAL,SAVE :: is_using_omp
     10  LOGICAL,SAVE :: is_north_pole_phy, is_south_pole_phy
    1011 
    1112  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb
    … …  
    1718  INTEGER,SAVE :: klon_omp_end
    1819!$OMP  THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end)
     20!$OMP  THREADPRIVATE(is_north_pole_phy, is_south_pole_phy)
    1921
    2022CONTAINS
    2123 
    2224  SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi)
    23     USE dimphy
     25    USE dimphy
     26    USE mod_phys_lmdz_mpi_data, ONLY : is_north_pole_dyn, is_south_pole_dyn
    2427    IMPLICIT NONE
    2528    INTEGER, INTENT(in) :: klon_mpi
    … …  
    4346        omp_size=OMP_GET_NUM_THREADS()
    4447!$OMP END MASTER
     48!$OMP BARRIER
    4549        omp_rank=OMP_GET_THREAD_NUM()   
    4650#else   
    … …  
    6266
    6367!$OMP MASTER
     68
    6469    ALLOCATE(klon_omp_para_nb(0:omp_size-1))
    6570    ALLOCATE(klon_omp_para_begin(0:omp_size-1))
    … …  
    8085!$OMP END MASTER
    8186!$OMP BARRIER
     87
     88   if ((is_north_pole_dyn) .AND. (omp_rank == 0 )) then
     89      is_north_pole_phy = .TRUE.
     90    else
     91      is_north_pole_phy = .FALSE.
     92    endif
     93    if ((is_south_pole_dyn) .AND. (omp_rank == omp_size-1)) then
     94      is_south_pole_phy = .TRUE.
     95    else
     96      is_south_pole_phy = .FALSE.
     97    endif
    8298   
    8399    klon_omp=klon_omp_para_nb(omp_rank)

  • LMDZ5/branches/testing/libf/phy_common/mod_phys_lmdz_para.F90

    • Property svn:keywords changed from Author Date Id Revision to Id
    r2408 r2435  
    11!
    2 !$Header$
     2! $Id$
    33!
    44MODULE mod_phys_lmdz_para
    … …  
    1111  LOGICAL,SAVE :: is_parallel
    1212  LOGICAL,SAVE :: is_master
     13
    1314 
    1415!$OMP THREADPRIVATE(klon_loc,is_master)
    … …  
    4142       is_parallel=.FALSE.
    4243     ENDIF
     44
     45
    4346     
    4447  END SUBROUTINE Init_phys_lmdz_para

  • LMDZ5/branches/testing/libf/phylmd/YOMCST2.h

    r2220 r2435  
    11
    2       INTEGER choice, iflag_mix
     2      INTEGER choice, iflag_mix, iflag_mix_adiab
    33      REAL  gammas, alphas, betas, Fmax, qqa1, qqa2, qqa3, scut
    44      REAL  Qcoef1max,Qcoef2max,Supcrit1,Supcrit2
    … …  
    99     &               Qcoef1max,Qcoef2max,                               &
    1010     &               Supcrit1, Supcrit2,                                &
    11      &               choice,iflag_mix,coef_clos_ls
     11     &               choice,iflag_mix,coef_clos_ls,iflag_mix_adiab
    1212!$OMP THREADPRIVATE(/YOMCST2/)
    1313!    --------------------------------------------------------------------

  • LMDZ5/branches/testing/libf/phylmd/add_phys_tend.F90

    r2408 r2435  
    1414!======================================================================
    1515
    16 use dimphy
    17 use phys_local_var_mod
    18 use phys_state_var_mod
    19 use print_control_mod, only: prt_level
     16USE dimphy, ONLY: klon, klev
     17USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, &
     18                              t_seri
     19USE phys_state_var_mod, ONLY: ftsol
     20USE geometry_mod, ONLY: longitude_deg, latitude_deg
     21USE print_control_mod, ONLY: prt_level
    2022IMPLICIT none
    2123  include "YOMCST.h"
    … …  
    106108         i=jadrs(j)
    107109         if(prt_level.ge.debug_level) THEN
    108           print*,'PLANTAGE POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
     110          print*,'PLANTAGE POUR LE POINT i lon lat =',&
     111                 i,longitude_deg(i),latitude_deg(i),text
    109112          print*,'l    T     dT       Q     dQ    '
    110113          DO k = 1, klev
    … …  
    124127        i=jqadrs(j)
    125128          if(prt_level.ge.debug_level) THEN
    126            print*,'WARNING  : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
     129           print*,'WARNING  : EAU POUR LE POINT i lon lat =',&
     130                  i,longitude_deg(i),latitude_deg(i),text
    127131           print*,'l    T     dT       Q     dQ    '
    128132           DO k = 1, klev
    … …  
    205209         k=kadrs(j)
    206210         if(prt_level.ge.debug_level) THEN
    207           print*,'PLANTAGE2 POUR LE POINT i itap rlon rlat txt jbad zdt t',i,itap,rlon(i),rlat(i),text,jbad, &
     211          print*,'PLANTAGE2 POUR LE POINT i itap lon lat txt jbad zdt t',&
     212                 i,itap,longitude_deg(i),latitude_deg(i),text,jbad, &
    208213       &        zdt(i,k),t_seri(i,k)-zdt(i,k)
    209214!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN
    … …  
    222227         k=kqadrs(j)
    223228         if(prt_level.ge.debug_level) THEN
    224           print*,'WARNING  : EAU2 POUR LE POINT i itap rlon rlat txt jqbad zdq q zdql ql',i,itap,rlon(i),rlat(i),text,jqbad,&
     229          print*,'WARNING  : EAU2 POUR LE POINT i itap lon lat txt jqbad zdq q zdql ql',&
     230                 i,itap,longitude_deg(i),latitude_deg(i),text,jqbad,&
    225231       &        zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k)
    226232!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN

  • LMDZ5/branches/testing/libf/phylmd/aero_mod.F90

    r2408 r2435  
    3131       "ASBCM  ", &
    3232       "ASPOMM ", &
    33        "SO4    ", &
     33       "ASSO4M ", &
    3434       "CSSO4M ", &
    3535       "SSSSM  ", &

  • LMDZ5/branches/testing/libf/phylmd/albedo.F90

    r2408 r2435  
    2222    include "clesphys.h"
    2323
    24     ! fmagic -> clesphys.h/.inc
    25     ! REAL fmagic ! un facteur magique pour regler l'albedo
    26     ! cc      PARAMETER (fmagic=0.7)
    27     ! ccIM => a remplacer
    28     ! PARAMETER (fmagic=1.32)
    29     ! PARAMETER (fmagic=1.0)
    30     ! PARAMETER (fmagic=0.7)
    3124    INTEGER npts ! il controle la precision de l'integration
    3225    PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
    … …  
    7467          END DO
    7568          IF (srmu/=0.0) THEN
    76              albedo(i) = salb/srmu*fmagic + pmagic
     69             albedo(i) = salb/srmu
    7770          ELSE ! nuit polaire (on peut prendre une valeur quelconque)
    78              albedo(i) = fmagic
     71             albedo(i) = 1.0
    7972          END IF
    8073       END DO
    … …  
    119112          END DO
    120113          IF (srmu/=0.0) THEN
    121              albedo(i) = salb/srmu*fmagic + pmagic
     114             albedo(i) = salb/srmu
    122115          ELSE ! nuit polaire (on peut prendre une valeur quelconque)
    123              albedo(i) = fmagic
     116             albedo(i) = 1.0
    124117          END IF
    125118       END DO
    … …  
    146139    real, intent(out):: albedo(klon)
    147140
    148     ! REAL fmagic ! un facteur magique pour regler l'albedo
    149     ! cc      PARAMETER (fmagic=0.7)
    150     ! ccIM => a remplacer
    151     ! PARAMETER (fmagic=1.32)
    152     ! PARAMETER (fmagic=1.0)
    153     ! PARAMETER (fmagic=0.7)
    154 
    155141    REAL fauxo
    156142    INTEGER i
    … …  
    161147       DO i = 1, klon
    162148          fauxo = (1.47-acos(max(rmu0(i), 0.0)))/0.15
    163           albedo(i) = fmagic*(.03+.630/(1.+fauxo*fauxo)) + pmagic
     149          albedo(i) = 0.03+.630/(1.+fauxo*fauxo)
    164150          albedo(i) = max(min(albedo(i),0.60), 0.04)
    165151       END DO
    166152    ELSE
    167153       DO i = 1, klon
    168           albedo(i) = fmagic*0.058/(max(rmu0(i), 0.0)+0.30) + pmagic
     154          albedo(i) = 0.058/(max(rmu0(i), 0.0)+0.30)
    169155          albedo(i) = max(min(albedo(i),0.60), 0.04)
    170156       END DO

  • LMDZ5/branches/testing/libf/phylmd/atm2geo.F90

    • Property svn:keywords changed from Author Date Id Revision to Id
    r2408 r2435  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
    … …  
    3232 
    3333! Value at North Pole 
    34   IF (is_north_pole) THEN
     34  IF (is_north_pole_dyn) THEN
    3535     pxx(:, 1) = - pte (1, 1)
    3636     pyy(:, 1) = - ptn (1, 1)
    … …  
    3939
    4040! Value at South Pole
    41   IF (is_south_pole) THEN
     41  IF (is_south_pole_dyn) THEN
    4242     pxx(:,jm) = pxx(1,jm)
    4343     pyy(:,jm) = pyy(1,jm)

  • LMDZ5/branches/testing/libf/phylmd/conf_phys_m.F90

    r2425 r2435  
    143143    REAL, SAVE :: supcrit1_omp, supcrit2_omp
    144144    INTEGER, SAVE :: iflag_mix_omp
     145    INTEGER, SAVE :: iflag_mix_adiab_omp
    145146    real, save :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp
    146147    REAL, SAVE :: tmax_fonte_cv_omp
    … …  
    202203    LOGICAL, SAVE :: ok_conserv_q_omp
    203204    INTEGER, SAVE :: iflag_fisrtilp_qsat_omp
     205    INTEGER, SAVE :: iflag_bergeron_omp
    204206    LOGICAL,SAVE :: ok_strato_omp
    205207    LOGICAL,SAVE :: ok_hines_omp, ok_gwd_rando_omp
    … …  
    754756
    755757    !Config  Key  = iflag_fisrtilp_qsat
    756     !Config  Desc = Flag de convection
    757     !Config  Def  = 1
    758     !Config  Help = Flag  pour la convection les options suivantes existent :
    759     !Config         -1 pour Kinetic energy correction
    760     !Config         1  conservation kinetic and enthalpy
     758    !Config  Desc = Flag de fisrtilp
     759    !Config  Def  = 0
     760    !Config  Help = Flag  pour la pluie grande-échelle les options suivantes existent :
     761    !Config         >1 nb iterations pour converger dans le calcul de qsat
    761762    iflag_fisrtilp_qsat_omp = 0
    762763    CALL getin('iflag_fisrtilp_qsat',iflag_fisrtilp_qsat_omp)
     764
     765    !Config  Key  = iflag_bergeron
     766    !Config  Desc = Flag de fisrtilp
     767    !Config  Def  = 0
     768    !Config  Help = Flag  pour la pluie grande-échelle les options suivantes existent :
     769    !Config         0 pas d effet Bergeron
     770    !Config         1 effet Bergeron pour T<0
     771    iflag_bergeron_omp = 0
     772    CALL getin('iflag_bergeron',iflag_bergeron_omp)
    763773
    764774    !
    … …  
    914924    !Config Help =
    915925    !
    916     NSW_omp = 6
     926    NSW_omp = 2
    917927    call getin('NSW',NSW_omp)
    918928    !albedo SB >>>
    … …  
    17461756    iflag_mix_omp = 1
    17471757    call getin('iflag_mix',iflag_mix_omp)
     1758
     1759!
     1760    ! PARAMETERS FOR THE EROSION OF THE ADIABATIC ASCENTS
     1761    ! iflag_mix_adiab: 0=OLD,
     1762    !                  1=NEW (CR),           
     1763    !           
     1764    !
     1765    !Config Key  = iflag_mix_adiab
     1766    !Config Desc =
     1767    !Config Def  = 1
     1768    !Config Help =
     1769    !
     1770    iflag_mix_adiab_omp = 0
     1771    call getin('iflag_mix_adiab',iflag_mix_adiab_omp)
    17481772
    17491773    !
    … …  
    19581982    ok_conserv_q = ok_conserv_q_omp
    19591983    iflag_fisrtilp_qsat = iflag_fisrtilp_qsat_omp
     1984    iflag_bergeron = iflag_bergeron_omp
    19601985
    19611986    epmax = epmax_omp
    … …  
    21232148    supcrit2 = supcrit2_omp
    21242149    iflag_mix = iflag_mix_omp
     2150    iflag_mix_adiab = iflag_mix_adiab_omp
    21252151    scut = scut_omp
    21262152    qqa1 = qqa1_omp
    … …  
    21652191       CALL abort_physic('conf_phys','version_ocean not valid',1)
    21662192    END IF
     2193
     2194    !--test on radiative scheme
     2195    IF (iflag_rrtm .EQ. 0) THEN
     2196      IF (NSW.NE.2) THEN
     2197        WRITE(lunout,*) ' ERROR iflag_rrtm=0 and NSW<>2 not possible'
     2198        CALL abort_physic('conf_phys','choice NSW not valid',1)
     2199      ENDIF
     2200    ELSE IF (iflag_rrtm .EQ. 1) THEN
     2201      IF (NSW.NE.2.AND.NSW.NE.4.AND.NSW.NE.6) THEN
     2202        WRITE(lunout,*) ' ERROR iflag_rrtm=1 and NSW<>2,4,6 not possible'
     2203        CALL abort_physic('conf_phys','choice NSW not valid',1)
     2204      ENDIF
     2205    ELSE
     2206       WRITE(lunout,*) ' ERROR iflag_rrtm<>0,1'
     2207       CALL abort_physic('conf_phys','choice iflag_rrtm not valid',1)
     2208    ENDIF
     2209
     2210    !--test on ocean surface albedo
     2211    IF (iflag_albedo.LT.0.OR.iflag_albedo.GT.1) THEN
     2212       WRITE(lunout,*) ' ERROR iflag_albedo<>0,1'
     2213       CALL abort_physic('conf_phys','choice iflag_albedo not valid',1)
     2214    ENDIF
    21672215
    21682216    ! Test sur new_aod. Ce flag permet de retrouver les resultats de l'AR4
    … …  
    22282276    write(lunout,*)'ok_conserv_q=',ok_conserv_q
    22292277    write(lunout,*)'iflag_fisrtilp_qsat=',iflag_fisrtilp_qsat
     2278    write(lunout,*)'iflag_bergeron=',iflag_bergeron
    22302279    write(lunout,*)' epmax = ', epmax
    22312280    write(lunout,*)' ok_adj_ema = ', ok_adj_ema
    … …  
    23242373    write(lunout,*)' supcrit2 = ', supcrit2
    23252374    write(lunout,*)' iflag_mix = ', iflag_mix
     2375    write(lunout,*)' iflag_mix_adiab = ', iflag_mix_adiab
    23262376    write(lunout,*)' scut = ', scut
    23272377    write(lunout,*)' qqa1 = ', qqa1

  • LMDZ5/branches/testing/libf/phylmd/cosp/MISR_simulator.F

    r2298 r2435  
    22! Copyright (c) 2009,  Roger Marchand, version 1.2
    33! All rights reserved.
     4! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     5! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MISR_simulator/MISR_simulator.f $
    46!
    57! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    2729     &     ncol,
    2830     &     sunlit,
    29      &     zfull,
    30      &     at,
     31     &     zfull,
     32     &     at,
    3133     &     dtau_s,
    32      &     dtau_c,
    33      &     frac_out,
    34      &     fq_MISR_TAU_v_CTH,
    35      &     dist_model_layertops,
    36      &     MISR_mean_ztop,
     34     &     dtau_c,
     35     &     frac_out,
     36     &     missing_value,
     37     &     fq_MISR_TAU_v_CTH,
     38     &     dist_model_layertops,
     39     &     MISR_mean_ztop,
    3740     &     MISR_cldarea
    3841     & )
    39        
     42   
    4043
    4144      implicit none
    … …  
    4851
    4952      INTEGER npoints                   !  if ncol ==1, the number of model points in the horizontal grid 
    50                                         !   else        the number of GCM grid points
    51                                        
     53                            !   else    the number of GCM grid points
     54                           
    5255      INTEGER nlev                      !  number of model vertical levels
    5356     
    5457      INTEGER ncol                      !  number of model sub columns
    55                                         !  (must already be generated in via scops and passed to this
    56                                         !   routine via the variable frac_out )
     58                        !  (must already be generated in via scops and passed to this
     59                        !   routine via the variable frac_out )
    5760 
    5861      INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
    5962
    60       REAL zfull(npoints,nlev)          !  height (in meters) of full model levels (i.e. midpoints)
     63      REAL zfull(npoints,nlev)          !  height (in meters) of full model levels (i.e. midpoints)
    6164                                        !  zfull(npoints,1)    is    top level of model
    6265                                        !  zfull(npoints,nlev) is bottom level of model (closest point to surface) 
    … …  
    6669      REAL dtau_s(npoints,nlev)         !  visible wavelength cloud optical depth ... for "stratiform" condensate
    6770                                        !  NOTE:  this the cloud optical depth of only the
    68                                         !         the model cell (i,j)
    69                                        
     71                    !     the model cell (i,j)
     72                   
    7073      REAL dtau_c(npoints,nlev)         !  visible wavelength cloud optical depth ... for "convective" condensate
    7174                                        !  NOTE:  this the cloud optical depth of only the
    72                                         !         the model cell (i,j)
     75                    !     the model cell (i,j)
    7376                                     
    7477      REAL frac_out(npoints,ncol,nlev)  !  NOTE: only need if columns>1 ... subgrid scheme in use.
     78     
     79      REAL missing_value
    7580                                 
    7681!     ------
    7782!     Outputs
    7883!     ------
    79                 
     84            
    8085      REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH)     
    8186      REAL dist_model_layertops(npoints,n_MISR_CTH)
    82       REAL MISR_cldarea(npoints)                       ! fractional area coverged by clouds
    83       REAL MISR_mean_ztop(npoints)                     ! mean cloud top hieght(m) MISR would observe
    84                                                        ! NOTE: == 0 if area ==0
    85                                                
     87      REAL MISR_cldarea(npoints)               ! fractional area coverged by clouds
     88      REAL MISR_mean_ztop(npoints)             ! mean cloud top hieght(m) MISR would observe
     89                                   ! NOTE: == 0 if area ==0
     90                           
    8691
    8792!     ------
    … …  
    8994!     ------
    9095
    91       REAL tau(npoints,ncol)            ! total column optical depth ...
    92 
    93       INTEGER j,ilev,ilev2,ibox
     96      REAL tau(npoints,ncol)        ! total column optical depth ...
     97
     98      INTEGER j,ilev,ilev2,ibox,k
    9499      INTEGER itau
    95100         
    … …  
    99104      real boxarea
    100105      real tauchk
    101       REAL box_MISR_ztop(npoints,ncol)  ! cloud top hieght(m) MISR would observe
     106      REAL box_MISR_ztop(npoints,ncol)  ! cloud top hieght(m) MISR would observe
    102107     
    103108      integer thres_crossed_MISR
    … …  
    109114     
    110115      DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3,
    111      c                                4, 5, 7, 9, 11, 13, 15, 17, 99 /
     116     c                    4, 5, 7, 9, 11, 13, 15, 17, 99 /
    112117     
    113118      DATA isccp_taumin / 0.3 /
    114119   
    115120      tauchk = -1.*log(0.9999999)
    116        
     121       
    117122      !
    118       ! For each GCM cell or horizontal model grid point ...
    119       ! 
    120       do j=1,npoints   
     123      ! For each GCM cell or horizontal model grid point ...
     124      ! 
     125      do j=1,npoints   
    121126
    122127         !
    123          !      estimate distribution of Model layer tops
    124          !     
     128         !  estimate distribution of Model layer tops
     129         ! 
    125130         dist_model_layertops(j,:)=0
    126131
    127          do ilev=1,nlev
    128                        
    129                 ! define location of "layer top"
    130                 if(ilev.eq.1 .or. ilev.eq.nlev) then
    131                         ztest=zfull(j,ilev)
    132                 else
    133                         ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1))
    134                 endif   
    135 
    136                 ! find MISR layer that contains this level
    137                 ! note, the first MISR level is "no height" level
    138                 iMISR_ztop=2
    139                 do loop=2,n_MISR_CTH
    140                
    141                         if ( ztest .gt.
    142      &                            1000*MISR_CTH_boundaries(loop+1) ) then
    143            
    144                                 iMISR_ztop=loop+1
    145                         endif
    146                 enddo
    147 
    148                 dist_model_layertops(j,iMISR_ztop)=
    149      &                  dist_model_layertops(j,iMISR_ztop)+1
    150         enddo
    151        
    152        
     132       do ilev=1,nlev
     133           
     134        ! define location of "layer top"
     135        if(ilev.eq.1 .or. ilev.eq.nlev) then
     136            ztest=zfull(j,ilev)
     137        else
     138            ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1))
     139        endif   
     140
     141        ! find MISR layer that contains this level
     142        ! note, the first MISR level is "no height" level
     143        iMISR_ztop=2
     144        do loop=2,n_MISR_CTH
     145       
     146            if ( ztest .gt.
     147     &                1000*MISR_CTH_boundaries(loop+1) ) then
     148       
     149                iMISR_ztop=loop+1
     150            endif
     151        enddo
     152
     153        dist_model_layertops(j,iMISR_ztop)=
     154     &          dist_model_layertops(j,iMISR_ztop)+1
     155      enddo
     156   
     157   
    153158         !
    154159         ! compute total cloud optical depth for each column
    155160         !       
    156          do ibox=1,ncol     
    157            
    158             ! Initialize tau to zero in each subcolum
    159             tau(j,ibox)=0.
    160             box_cloudy(j,ibox)=.false.
    161             box_MISR_ztop(j,ibox)=0 
    162            
    163             ! initialize threshold detection for each sub column
    164             thres_crossed_MISR=0;
    165            
    166             do ilev=1,nlev
     161       do ibox=1,ncol     
     162       
     163        ! Initialize tau to zero in each subcolum
     164            tau(j,ibox)=0.
     165        box_cloudy(j,ibox)=.false.
     166        box_MISR_ztop(j,ibox)=0 
     167       
     168        ! initialize threshold detection for each sub column
     169        thres_crossed_MISR=0;
     170       
     171        do ilev=1,nlev
    167172     
    168                  dtau=0
    169                 
    170                  if (frac_out(j,ibox,ilev).eq.1) then
     173             dtau=0
     174            
     175             if (frac_out(j,ibox,ilev).eq.1) then
    171176                        dtau = dtau_s(j,ilev)
    172177                 endif
    … …  
    174179                 if (frac_out(j,ibox,ilev).eq.2) then
    175180                        dtau = dtau_c(j,ilev)
    176                  end if 
     181                 end if 
    177182                 
    178                 tau(j,ibox)=tau(j,ibox)+ dtau
    179                  
    180                        
    181                 ! NOW for MISR ..
    182                 ! if there a cloud ... start the counter ... store this height
    183                 if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then
    184                
    185                         ! first encountered a "cloud"
    186                         thres_crossed_MISR=1 
    187                         cloud_dtau=0                   
    188                 endif   
    189                                
    190                 if( thres_crossed_MISR .lt. 99 .and.
    191      &                  thres_crossed_MISR .gt. 0 ) then
     183            tau(j,ibox)=tau(j,ibox)+ dtau
     184             
     185                   
     186        ! NOW for MISR ..
     187        ! if there a cloud ... start the counter ... store this height
     188        if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then
     189       
     190            ! first encountered a "cloud"
     191            thres_crossed_MISR=1 
     192            cloud_dtau=0           
     193        endif   
     194               
     195        if( thres_crossed_MISR .lt. 99 .and.
     196     &              thres_crossed_MISR .gt. 0 ) then
    192197     
    193                         if( dtau .eq. 0.) then
    194                
    195                                 ! we have come to the end of the current cloud
    196                                 ! layer without yet selecting a CTH boundary.
    197                                 ! ... restart cloud tau counter
    198                                 cloud_dtau=0
    199                         else
    200                                 ! add current optical depth to count for
    201                                 ! the current cloud layer
    202                                 cloud_dtau=cloud_dtau+dtau
    203                         endif
    204                                
    205                         ! if the cloud is continuous but optically thin (< 1)
    206                         ! from above the current layer cloud top to the current level
    207                         ! then MISR will like see a top below the top of the current
    208                         ! layer
    209                         if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
    210                        
    211                                 if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
    212 
    213                                         ! MISR will likely penetrate to some point
    214                                         ! within this layer ... the middle
    215                                         MISR_penetration_height=zfull(j,ilev)
    216 
    217                                 else
    218                                         ! take the OD = 1.0 level into this layer
    219                                         MISR_penetration_height=
    220      &                                     0.5*(zfull(j,ilev)+zfull(j,ilev-1)) -
    221      &                                     0.5*(zfull(j,ilev-1)-zfull(j,ilev+1))
    222      &                                  /dtau
    223                                 endif   
    224 
    225                                 box_MISR_ztop(j,ibox)=MISR_penetration_height
    226                                
    227                         endif
    228                
    229                         ! check for a distinctive water layer
    230                         if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then
     198                if( dtau .eq. 0.) then
     199       
     200                    ! we have come to the end of the current cloud
     201                ! layer without yet selecting a CTH boundary.
     202                ! ... restart cloud tau counter
     203                cloud_dtau=0
     204            else
     205                ! add current optical depth to count for
     206                ! the current cloud layer
     207                cloud_dtau=cloud_dtau+dtau
     208            endif
     209               
     210            ! if the cloud is continuous but optically thin (< 1)
     211            ! from above the current layer cloud top to the current level
     212            ! then MISR will like see a top below the top of the current
     213            ! layer
     214            if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
     215           
     216                if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
     217
     218                    ! MISR will likely penetrate to some point
     219                    ! within this layer ... the middle
     220                    MISR_penetration_height=zfull(j,ilev)
     221
     222                else
     223                    ! take the OD = 1.0 level into this layer
     224                    MISR_penetration_height=
     225     &                     0.5*(zfull(j,ilev)+zfull(j,ilev-1)) -
     226     &                     0.5*(zfull(j,ilev-1)-zfull(j,ilev+1))
     227     &                  /dtau
     228                endif   
     229
     230                box_MISR_ztop(j,ibox)=MISR_penetration_height
     231               
     232            endif
     233       
     234            ! check for a distinctive water layer
     235            if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then
    231236     
    232                                 ! must be a water cloud ...
    233                                 ! take this as CTH level
    234                                 thres_crossed_MISR=99
    235                         endif
    236                
    237                         ! if the total column optical depth is "large" than
    238                         ! MISR can't seen anything else ... set current point as CTH level
    239                         if(tau(j,ibox) .gt. 5) then     
    240 
    241                                 thres_crossed_MISR=99                   
    242                         endif
    243 
    244                 endif ! MISR CTH booundary not set
    245                
    246             enddo  !ilev - loop over vertical levesl
    247        
    248             ! written by roj 5/2006
    249             ! check to see if there was a cloud for which we didn't
    250             ! set a MISR cloud top boundary
    251             if( thres_crossed_MISR .eq. 1) then
    252        
    253                 ! if the cloud has a total optical depth of greater
    254                 ! than ~ 0.5 MISR will still likely pick up this cloud
    255                 ! with a height near the true cloud top
    256                 ! otherwise there should be no CTH
    257                 if( tau(j,ibox) .gt. 0.5) then
    258 
    259                         ! keep MISR detected CTH
    260                        
    261                 elseif(tau(j,ibox) .gt. 0.2) then
    262 
    263                         ! MISR may detect but wont likley have a good height
    264                         box_MISR_ztop(j,ibox)=-1
    265                        
    266                 else
    267                         ! MISR not likely to even detect.
    268                         ! so set as not cloudy
    269                         box_MISR_ztop(j,ibox)=0
    270 
    271                 endif
    272                                                
    273             endif
    274        
    275         enddo  ! loop of subcolumns
     237                    ! must be a water cloud ...
     238                ! take this as CTH level
     239                thres_crossed_MISR=99
     240            endif
     241       
     242            ! if the total column optical depth is "large" than
     243            ! MISR can't seen anything else ... set current point as CTH level
     244            if(tau(j,ibox) .gt. 5) then
     245
     246                thres_crossed_MISR=99           
     247            endif
     248
     249        endif ! MISR CTH booundary not set
     250       
     251        enddo  !ilev - loop over vertical levesl
     252   
     253        ! written by roj 5/2006
     254        ! check to see if there was a cloud for which we didn't
     255        ! set a MISR cloud top boundary
     256        if( thres_crossed_MISR .eq. 1) then
     257   
     258        ! if the cloud has a total optical depth of greater
     259        ! than ~ 0.5 MISR will still likely pick up this cloud
     260        ! with a height near the true cloud top
     261        ! otherwise there should be no CTH
     262        if( tau(j,ibox) .gt. 0.5) then
     263
     264            ! keep MISR detected CTH
     265           
     266        elseif(tau(j,ibox) .gt. 0.2) then
     267
     268            ! MISR may detect but wont likley have a good height
     269            box_MISR_ztop(j,ibox)=-1
     270           
     271        else
     272            ! MISR not likely to even detect.
     273            ! so set as not cloudy
     274            box_MISR_ztop(j,ibox)=0
     275
     276        endif
     277                       
     278        endif
     279   
     280      enddo  ! loop of subcolumns
    276281       enddo    ! loop of gridpoints
    277282       
    278283
    279284        !     
    280         !       Modify MISR CTH for satellite spatial / pattern matcher effects
    281         !
    282         !       Code in this region added by roj 5/2006 to account
    283         !       for spatial effect of the MISR pattern matcher.
    284         !       Basically, if a column is found between two neighbors
    285         !       at the same CTH, and that column has no hieght or
    286         !       a lower CTH, THEN misr will tend to but place the
    287         !       odd column at the same height as it neighbors.
    288         !
    289         !       This setup assumes the columns represent a about a 1 to 4 km scale
    290         !       it will need to be modified significantly, otherwise
    291         if(ncol.eq.1) then
    292        
    293            ! adjust based on neightboring points ... i.e. only 2D grid was input
     285        !   Modify MISR CTH for satellite spatial / pattern matcher effects
     286    !
     287    !   Code in this region added by roj 5/2006 to account
     288    !   for spatial effect of the MISR pattern matcher.
     289    !   Basically, if a column is found between two neighbors
     290    !   at the same CTH, and that column has no hieght or
     291    !   a lower CTH, THEN misr will tend to but place the
     292    !   odd column at the same height as it neighbors.
     293    !
     294    !   This setup assumes the columns represent a about a 1 to 4 km scale
     295    !   it will need to be modified significantly, otherwise
     296        if(ncol.eq.1) then
     297   
     298       ! adjust based on neightboring points ... i.e. only 2D grid was input
    294299           do j=2,npoints-1
    295                        
    296                         if(box_MISR_ztop(j-1,1).gt.0 .and.
    297      &                     box_MISR_ztop(j+1,1).gt.0       ) then
    298 
    299                                 if( abs( box_MISR_ztop(j-1,1) - 
    300      &                                  box_MISR_ztop(j+1,1) ) .lt. 500
    301      &                          .and.
    302      &                                  box_MISR_ztop(j,1) .lt.
    303      &                                  box_MISR_ztop(j+1,1)     ) then
    304                        
    305                                         box_MISR_ztop(j,1) =
    306      &                                          box_MISR_ztop(j+1,1)   
    307                                 endif
    308 
    309                         endif
     300           
     301            if(box_MISR_ztop(j-1,1).gt.0 .and.
     302     &             box_MISR_ztop(j+1,1).gt.0       ) then
     303
     304                if( abs( box_MISR_ztop(j-1,1) - 
     305     &                  box_MISR_ztop(j+1,1) ) .lt. 500
     306     &              .and.
     307     &                  box_MISR_ztop(j,1) .lt.
     308     &                  box_MISR_ztop(j+1,1)     ) then
     309           
     310                    box_MISR_ztop(j,1) =
     311     &                      box_MISR_ztop(j+1,1)   
     312                endif
     313
     314            endif
    310315         enddo
    311       else
     316        else
    312317         
    313318         ! adjust based on neighboring subcolumns ....
    314319         do ibox=2,ncol-1
    315                        
    316                         if(box_MISR_ztop(1,ibox-1).gt.0 .and.
    317      &                     box_MISR_ztop(1,ibox+1).gt.0            ) then
    318 
    319                                 if( abs( box_MISR_ztop(1,ibox-1) - 
    320      &                                  box_MISR_ztop(1,ibox+1) ) .lt. 500
    321      &                          .and.
    322      &                                  box_MISR_ztop(1,ibox) .lt.
    323      &                                  box_MISR_ztop(1,ibox+1)     ) then
    324                        
    325                                         box_MISR_ztop(1,ibox) =
    326      &                                          box_MISR_ztop(1,ibox+1)   
    327                                 endif
    328 
    329                         endif
     320           
     321            if(box_MISR_ztop(1,ibox-1).gt.0 .and.
     322     &             box_MISR_ztop(1,ibox+1).gt.0        ) then
     323
     324                if( abs( box_MISR_ztop(1,ibox-1) - 
     325     &                  box_MISR_ztop(1,ibox+1) ) .lt. 500
     326     &              .and.
     327     &                  box_MISR_ztop(1,ibox) .lt.
     328     &                  box_MISR_ztop(1,ibox+1)     ) then
     329           
     330                    box_MISR_ztop(1,ibox) =
     331     &                      box_MISR_ztop(1,ibox+1)   
     332                endif
     333
     334            endif
    330335         enddo
    331336     
    332       endif
     337        endif
    333338
    334339        !     
    335         !     DETERMINE CLOUD TYPE FREQUENCIES
    336         !
    337         !     Now that ztop and tau have been determined,
    338         !     determine amount of each cloud type
    339       boxarea=1./real(ncol) 
    340       do j=1,npoints
     340    !     DETERMINE CLOUD TYPE FREQUENCIES
     341    !
     342    !     Now that ztop and tau have been determined,
     343    !     determine amount of each cloud type
     344        boxarea=1./real(ncol) 
     345        do j=1,npoints
    341346
    342347         ! reset frequencies -- modified loop structure, roj 5/2006
    343          do ilev=1,7  ! "tau loop"     
    344             do  ilev2=1,n_MISR_CTH                             
    345                 fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.     
     348         do ilev=1,7  ! "tau loop" 
     349            do  ilev2=1,n_MISR_CTH                     
     350            fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.     
    346351            enddo
    347         enddo
    348            
    349         MISR_cldarea(j)=0.
    350         MISR_mean_ztop(j)=0.
     352        enddo
     353           
     354        MISR_cldarea(j)=0.
     355        MISR_mean_ztop(j)=0.
    351356
    352357         do ibox=1,ncol
    … …  
    356361            endif
    357362 
    358             itau = 0
    359            
     363            itau = 0
     364       
    360365            if (box_cloudy(j,ibox)) then
    361        
    362               !determine optical depth category
     366   
     367          !determine optical depth category
    363368              if (tau(j,ibox) .lt. isccp_taumin) then
    364369                  itau=1
    … …  
    382387              endif
    383388             
    384            endif 
    385 
    386            ! update MISR histograms and summary metrics - roj 5/2005
    387            if (sunlit(j).eq.1) then
    388                      
     389             endif 
     390
     391       ! update MISR histograms and summary metrics - roj 5/2005
     392       if (sunlit(j).eq.1) then
     393                     
    389394              !if cloudy added by roj 5/2005
    390               if( box_MISR_ztop(j,ibox).eq.0) then
    391              
    392                         ! no cloud detected
    393                         iMISR_ztop=0
    394 
    395               elseif( box_MISR_ztop(j,ibox).eq.-1) then
    396 
    397                         ! cloud can be detected but too thin to get CTH
    398                         iMISR_ztop=1   
    399 
    400                         fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
    401      &                          fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
    402 
    403               else
    404                
    405                         !
    406                         ! determine index for MISR bin set
    407                         !
    408 
    409                         iMISR_ztop=2
    410                        
    411                         do loop=2,n_MISR_CTH
    412                
    413                                 if ( box_MISR_ztop(j,ibox) .gt.
    414      &                            1000*MISR_CTH_boundaries(loop+1) ) then
    415            
    416                                   iMISR_ztop=loop+1
    417 
    418                                 endif
    419                         enddo
    420              
    421                         if(box_cloudy(j,ibox)) then
    422                        
    423                                 ! there is an isccp clouds so itau(j) is defined
    424                                 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
    425      &                                  fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
     395          if( box_MISR_ztop(j,ibox).eq.0) then
     396         
     397            ! no cloud detected
     398            iMISR_ztop=0
     399
     400          elseif( box_MISR_ztop(j,ibox).eq.-1) then
     401
     402            ! cloud can be detected but too thin to get CTH
     403            iMISR_ztop=1   
     404
     405            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
     406     &            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
     407
     408          else
     409           
     410            !
     411            ! determine index for MISR bin set
     412            !
     413
     414            iMISR_ztop=2
     415           
     416            do loop=2,n_MISR_CTH
     417       
     418                if ( box_MISR_ztop(j,ibox) .gt.
     419     &                1000*MISR_CTH_boundaries(loop+1) ) then
     420       
     421                  iMISR_ztop=loop+1
     422
     423                endif
     424            enddo
     425         
     426            if(box_cloudy(j,ibox)) then
     427           
     428               ! there is an isccp clouds so itau(j) is defined
     429               fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
     430     &            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
    426431     
    427                         else
    428                                 ! MISR CTH resolution is trying to fill in a
    429                                 ! broken cloud scene where there is no condensate.
    430                                 ! The MISR CTH-1D-OD product will only put in a cloud
    431                                 ! if the MISR cloud mask indicates cloud.
    432                                 ! therefore we will not include this column in the histogram
    433                                 ! in reality aerosoal and 3D effects or bright surfaces
    434                                 ! could fool the MISR cloud mask
    435 
    436                                 ! the alternative is to count as very thin cloud ??
    437 !                               fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
    438 !     &                                 fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
    439                         endif
    440 
    441 
    442                         MISR_mean_ztop(j)=MISR_mean_ztop(j)+
    443      &                                       box_MISR_ztop(j,ibox)*boxarea             
    444 
    445                         MISR_cldarea(j)=MISR_cldarea(j) + boxarea
     432            else
     433                ! MISR CTH resolution is trying to fill in a
     434                ! broken cloud scene where there is no condensate.
     435                ! The MISR CTH-1D-OD product will only put in a cloud
     436                ! if the MISR cloud mask indicates cloud.
     437                ! therefore we will not include this column in the histogram
     438                ! in reality aerosoal and 3D effects or bright surfaces
     439                ! could fool the MISR cloud mask
     440
     441                ! the alternative is to count as very thin cloud ??
     442!               fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
     443!     &                     fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
     444            endif
     445
     446
     447            MISR_mean_ztop(j)=MISR_mean_ztop(j)+
     448     &                       box_MISR_ztop(j,ibox)*boxarea         
     449
     450            MISR_cldarea(j)=MISR_cldarea(j) + boxarea
    446451 
    447               endif
    448                
    449            endif ! is sunlight ?
    450            
    451         enddo ! ibox - loop over subcolumns         
    452      
    453         if( MISR_cldarea(j) .gt. 0.) then
    454                 MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
    455         endif
    456 
    457       enddo  ! loop over grid points
     452          endif
     453       else
     454          ! Set to issing data. A. Bodas - 14/05/2010
     455          do loop=1,n_MISR_CTH
     456             do k=1,7
     457                fq_MISR_TAU_v_CTH(j,k,loop) = missing_value
     458             enddo
     459             dist_model_layertops(j,loop) = missing_value
     460          enddo
     461          MISR_cldarea(j) = missing_value
     462          MISR_mean_ztop(npoints) = missing_value
     463
     464       endif ! is sunlight ?
     465       
     466       enddo ! ibox - loop over subcolumns         
     467     
     468       if( MISR_cldarea(j) .gt. 0.) then
     469        MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
     470       endif
     471
     472       enddo  ! loop over grid points
    458473
    459474      return

  • LMDZ5/branches/testing/libf/phylmd/cosp/array_lib.F90

    r2298 r2435  
     1! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/array_lib.f90 $
    13! ARRAY_LIB: Array procedures for F90
    24! Compiled/Modified:

  • LMDZ5/branches/testing/libf/phylmd/cosp/atmos_lib.F90

    r2298 r2435  
     1! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/atmos_lib.f90 $
    13! ATMOS_LIB: Atmospheric science procedures for F90
    24! Compiled/Modified:
    … …  
    6466            32.2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, &
    6567            0.951000,0.0671000,0.000300000/)
    66            
     68        
    6769    tk =  (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, &
    6870            261.000, 255.000, 248.000, 242.000, 235.000, 229.000, &
    … …  
    124126            1.55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, &
    125127            0.000162076,0.000362055,7.68645e-06/)
    126            
     128        
    127129  case default
    128130    print *, 'Must enter a profile type'

  • LMDZ5/branches/testing/libf/phylmd/cosp/congvec.h

    r2298 r2435  
    33! (c) British Crown Copyright 2009, the Met Office.
    44! All rights reserved.
     5! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     6! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/congvec.f $
    57!
    68! Redistribution and use in source and binary forms, with or without

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp.F90

    r2298 r2435  
    2323! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    2424
    25 !!#include "cosp_defs.h"
     25#include "cosp_defs.h"
    2626MODULE MOD_COSP
    2727  USE MOD_COSP_TYPES
    2828  USE MOD_COSP_SIMULATOR
    29   USE mod_phys_lmdz_para
    30   USE mod_grid_phy_lmdz
     29  USE MOD_COSP_MODIS_SIMULATOR
    3130  IMPLICIT NONE
    3231
    … …  
    3736!--------------------- SUBROUTINE COSP ---------------------------
    3837!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    39 SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
    40 
     38!#ifdef RTTOV
     39!SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
     40!#else
     41SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     42!#endif
    4143  ! Arguments
    4244  integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
    … …  
    5052  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
    5153  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
     54  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
     55!#ifdef RTTOV
     56!  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
     57!#endif
    5258  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
    5359  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
    … …  
    5965  integer :: Niter     ! Number of calls to cosp_simulator
    6066  integer :: i_first,i_last ! First and last gridbox to be processed in each iteration
    61   integer :: i,j,k,Ni
     67  integer :: i,Ni
    6268  integer,dimension(2) :: ix,iy
    6369  logical :: reff_zero
    64   real :: minv,maxv
    6570  real :: maxp,minp
    66   integer,dimension(:),save,  allocatable :: & ! Dimensions nPoints
     71  integer,dimension(:),allocatable :: & ! Dimensions nPoints
    6772                  seed    !  It is recommended that the seed is set to a different value for each model
    6873                          !  gridbox it is called on, as it is possible that the choice of the same
    6974                          !  seed value every time may introduce some statistical bias in the results,
    7075                          !  particularly for low values of NCOL.
    71 !$OMP THREADPRIVATE(seed)
    72   real,dimension(:),allocatable :: rseed    !  It is recommended that the seed is set to a different value for each model
    7376  ! Types used in one iteration
    7477  type(cosp_gridbox) :: gbx_it
    … …  
    7881  type(cosp_sglidar) :: sglidar_it
    7982  type(cosp_isccp)   :: isccp_it
     83  type(cosp_modis)   :: modis_it
    8084  type(cosp_misr)    :: misr_it
     85!#ifdef RTTOV
     86!  type(cosp_rttov)   :: rttov_it
     87!#endif
    8188  type(cosp_radarstats) :: stradar_it
    8289  type(cosp_lidarstats) :: stlidar_it
    83  
    84   logical,save :: first_cosp=.TRUE.
    85 !$OMP THREADPRIVATE(first_cosp)
    86  
    87   !++++++++++ Dimensions ++++++++++++
     90
     91!++++++++++ Dimensions ++++++++++++
    8892  Npoints  = gbx%Npoints
    8993  Nlevels  = gbx%Nlevels
    9094  Nhydro   = gbx%Nhydro
     95
     96!++++++++++ Depth of model layers ++++++++++++
     97  do i=1,Nlevels-1
     98    gbx%dlev(:,i) = gbx%zlev_half(:,i+1) - gbx%zlev_half(:,i)
     99  enddo
     100  gbx%dlev(:,Nlevels) = 2.0*(gbx%zlev(:,Nlevels) - gbx%zlev_half(:,Nlevels))
    91101
    92102!++++++++++ Apply sanity checks to inputs ++++++++++
    … …  
    129139      !     and reff_zero    == .false.  Reff use in lidar and set to 0 for radar
    130140  endif
    131 !  if ((gbx%use_reff) .and. (reff_zero)) then ! Inconsistent choice. Want to use Reff but not inputs passed
    132 !        print *, '---------- COSP ERROR ------------'
    133 !        print *, ''
    134 !        print *, 'use_reff==.true. but Reff is always zero'
    135 !        print *, ''
    136 !        print *, '----------------------------------'
    137 !        stop
    138 !  endif
    139141  if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar
    140142        gbx%Reff = DEFAULT_LIDAR_REFF
    … …  
    170172  endif
    171173
    172   if (first_cosp) then   
    173174   ! We base the seed in the decimal part of the surface pressure.
    174      allocate(seed(Npoints))
    175 
    176      allocate(rseed(klon_glo))
    177      CALL gather(gbx%psfc,rseed)
    178      call bcast(rseed)
    179 !   seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1   
     175   allocate(seed(Npoints))
     176   seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1   
    180177      ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to
    181178      ! randomize for each call to COSP even when Npoints ==1
    182      minp = minval(rseed)
    183      maxp = maxval(rseed)
    184    
    185      if (Npoints .gt. 1) THEN
    186        seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1
    187      else
    188        seed=int(gbx%psfc-minp)
    189      endif
    190 
    191      deallocate(rseed)
    192      first_cosp=.false.
    193    endif
    194    
     179   minp = minval(gbx%psfc)
     180   maxp = maxval(gbx%psfc)
     181   if (Npoints .gt. 1) seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1
     182   ! Below it's how it was done in the original implementation of the ISCCP simulator.
     183   ! The one above is better for offline data, when you may have packed data
     184   ! that subsamples the decimal fraction of the surface pressure.
     185!    if (Npoints .gt. 1) seed=(gbx%psfc-int(gbx%psfc))*1000000
     186
     187 
    195188   if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints
    196         call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
     189!#ifdef RTTOV
     190!        call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
     191!#else
     192        call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     193!#endif
    197194   else ! Several iterations to save memory
    198195        Niter = gbx%Npoints/gbx%Npoints_it ! Integer division
    … …  
    205202            if (i == 1) then
    206203                ! Allocate types for all but last iteration
    207                 call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, &
    208                                             gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
     204                call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, &
     205                                            gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, &
     206                                            Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
    209207                                            gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
    210208                                            gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
    … …  
    219217                call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
    220218                call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
     219                call construct_cosp_modis(cfg, Ni, modis_it)
    221220                call construct_cosp_misr(cfg,Ni,misr_it)
     221!#ifdef RTTOV
     222!                call construct_cosp_rttov(Ni,gbx%nchan,rttov_it)
     223!#endif
    222224                call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
    223225                call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
    … …  
    229231                call free_cosp_sglidar(sglidar_it)
    230232                call free_cosp_isccp(isccp_it)
     233                call free_cosp_modis(modis_it)
    231234                call free_cosp_misr(misr_it)
     235!#ifdef RTTOV
     236!                call free_cosp_rttov(rttov_it)
     237!#endif
    232238                call free_cosp_radarstats(stradar_it)
    233239                call free_cosp_lidarstats(stlidar_it)
    234240                ! Allocate types for iterations
    235                 call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, &
    236                                             gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
     241                call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, &
     242                                            gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, &
     243                                            Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
    237244                                            gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
    238245                                            gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
    … …  
    250257                call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
    251258                call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
     259                call construct_cosp_modis(cfg,Ni, modis_it)
    252260                call construct_cosp_misr(cfg,Ni,misr_it)
     261!#ifdef RTTOV
     262!                call construct_cosp_rttov(Ni,gbx%nchan,rttov_it)
     263!#endif
    253264                call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
    254265                call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
    … …  
    263274            if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it)
    264275            if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it)
     276            if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis,modis_it)
    265277            if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr,misr_it)
     278!#ifdef RTTOV
     279!            if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov,rttov_it)
     280!#endif
    266281            if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it)
    267282            if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it)
    268             print *,'---------ix: ',ix
     283!#ifdef RTTOV
     284!            call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
     285!                           sglidar_it,isccp_it,misr_it,modis_it,rttov_it,stradar_it,stlidar_it)
     286!#else
    269287            call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
    270                            sglidar_it,isccp_it,misr_it,stradar_it,stlidar_it)
    271            
     288                           sglidar_it,isccp_it,misr_it,modis_it,stradar_it,stlidar_it)
     289!#endif
    272290            ! --- Copy results to output structures ---
    273 !             call cosp_gridbox_cphp(gbx_it,gbx)
    274291            ix=(/1,Ni/)
    275292            iy=(/i_first,i_last/)
    … …  
    278295            if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar)
    279296            if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp)
     297            if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis_it,modis)
    280298            if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr_it,misr)
     299!#ifdef RTTOV
     300!            if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov_it,rttov)
     301!#endif
    281302            if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar)
    282303            if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar)
    … …  
    289310        call free_cosp_sglidar(sglidar_it)
    290311        call free_cosp_isccp(isccp_it)
     312        call free_cosp_modis(modis_it)
    291313        call free_cosp_misr(misr_it)
     314!#ifdef RTTOV
     315!        call free_cosp_rttov(rttov_it)
     316!#endif
    292317        call free_cosp_radarstats(stradar_it)
    293318        call free_cosp_lidarstats(stlidar_it)
    294319   endif
     320   deallocate(seed)
    295321
    296322   
    … …  
    300326!--------------------- SUBROUTINE COSP_ITER ----------------------
    301327!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    302 SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
    303 
     328!#ifdef RTTOV
     329!SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
     330!#else
     331SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     332!#endif
    304333  ! Arguments
    305334  integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
    … …  
    313342  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
    314343  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
     344  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
     345!#ifdef RTTOV
     346!  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
     347!#endif
    315348  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
    316349  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
    … …  
    321354  integer :: Nlevels   ! Number of levels
    322355  integer :: Nhydro    ! Number of hydrometeors
    323   integer :: Niter     ! Number of calls to cosp_simulator
    324356  integer :: i,j,k
    325   integer :: I_HYDRO
     357  integer :: I_HYDRO 
    326358  real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out
    327   integer,parameter :: scops_debug=0    !  set to non-zero value to print out inputs for debugging in SCOPS
    328  
     359  real,dimension(:,:),pointer :: column_prec_out ! Array with one column of prec_frac
     360  integer :: scops_debug=0    !  set to non-zero value to print out inputs for debugging in SCOPS
    329361  real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, &
    330362                     tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud.
    … …  
    332364  real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level
    333365                                                                     ! Levels are from SURFACE to TOA
    334   real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric dens
     366  real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric density
    335367  type(cosp_sghydro) :: sghydro   ! Subgrid info for hydrometeors en each iteration
    336368
    … …  
    342374  Nhydro   = gbx%Nhydro
    343375   
    344    
    345376  !++++++++++ Climate/NWP mode ++++++++++ 
    346377  if (Ncolumns > 1) then
    … …  
    411442       ! Deallocate arrays that will no longer be used
    412443        deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate)
    413          
     444
    414445        ! Populate the subgrid arrays
    415446        call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
    … …  
    420451                sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ)
    421452                sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE)
    422                
     453
    423454                sghydro%Reff(:,k,:,I_LSCLIQ)     = gbx%Reff(:,:,I_LSCLIQ)
    424455                sghydro%Reff(:,k,:,I_LSCICE)     = gbx%Reff(:,:,I_LSCICE)
    425                 sghydro%Reff(:,k,:,I_LSRAIN)     = gbx%Reff(:,:,I_LSRAIN)
    426                 sghydro%Reff(:,k,:,I_LSSNOW)     = gbx%Reff(:,:,I_LSSNOW)
    427                 sghydro%Reff(:,k,:,I_LSGRPL)     = gbx%Reff(:,:,I_LSGRPL)
     456
     457                sghydro%Np(:,k,:,I_LSCLIQ)     = gbx%Np(:,:,I_LSCLIQ)
     458                sghydro%Np(:,k,:,I_LSCICE)     = gbx%Np(:,:,I_LSCICE)
     459
    428460            elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++
    429                 sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ)
    430                 sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE)
    431                
    432                 sghydro%Reff(:,k,:,I_CVCLIQ)     = gbx%Reff(:,:,I_CVCLIQ)
    433                 sghydro%Reff(:,k,:,I_CVCICE)     = gbx%Reff(:,:,I_CVCICE)
    434                 sghydro%Reff(:,k,:,I_CVRAIN)     = gbx%Reff(:,:,I_CVRAIN)
    435                 sghydro%Reff(:,k,:,I_CVSNOW)     = gbx%Reff(:,:,I_CVSNOW)
    436             end where
     461                sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ)
     462                sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE)
     463
     464                sghydro%Reff(:,k,:,I_CVCLIQ)     = gbx%Reff(:,:,I_CVCLIQ)
     465                sghydro%Reff(:,k,:,I_CVCICE)     = gbx%Reff(:,:,I_CVCICE)
     466
     467                sghydro%Np(:,k,:,I_CVCLIQ)     = gbx%Np(:,:,I_CVCLIQ)
     468                sghydro%Np(:,k,:,I_CVCICE)     = gbx%Np(:,:,I_CVCICE)
     469
     470            end where
     471            column_prec_out => sgx%prec_frac(:,k,:)
     472            where ((column_prec_out == 1) .or. (column_prec_out == 3) )  !++++ LS precip ++++
     473                sghydro%Reff(:,k,:,I_LSRAIN) = gbx%Reff(:,:,I_LSRAIN)
     474                sghydro%Reff(:,k,:,I_LSSNOW) = gbx%Reff(:,:,I_LSSNOW)
     475                sghydro%Reff(:,k,:,I_LSGRPL) = gbx%Reff(:,:,I_LSGRPL)
     476
     477                sghydro%Np(:,k,:,I_LSRAIN)     = gbx%Np(:,:,I_LSRAIN)
     478                sghydro%Np(:,k,:,I_LSSNOW)     = gbx%Np(:,:,I_LSSNOW)
     479                sghydro%Np(:,k,:,I_LSGRPL)     = gbx%Np(:,:,I_LSGRPL)
     480            elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3)) !++++ CONV precip ++++
     481                sghydro%Reff(:,k,:,I_CVRAIN) = gbx%Reff(:,:,I_CVRAIN)
     482                sghydro%Reff(:,k,:,I_CVSNOW) = gbx%Reff(:,:,I_CVSNOW)
     483
     484                sghydro%Np(:,k,:,I_CVRAIN)     = gbx%Np(:,:,I_CVRAIN)
     485                sghydro%Np(:,k,:,I_CVSNOW)     = gbx%Np(:,:,I_CVSNOW)
     486            end where
    437487            !--------- Precip -------
    438488            if (.not. gbx%use_precipitation_fluxes) then
    … …  
    442492                    sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL)
    443493                elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++
    444                     sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) 
    445                     sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) 
     494                    sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN)
     495                    sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW)
    446496                end where
    447497            endif
    … …  
    486536       
    487537        if (gbx%use_precipitation_fluxes) then
    488             ! convert precipitation flux into mixing ratio
    489             call pf_to_mr(Npoints,Nlevels,Ncolumns,gbx%rain_ls,gbx%snow_ls,gbx%grpl_ls, &
    490                         gbx%rain_cv,gbx%snow_cv,sgx%prec_frac,gbx%p,gbx%T, &
    491                         sghydro%mr_hydro(:,:,:,I_LSRAIN),sghydro%mr_hydro(:,:,:,I_LSSNOW),sghydro%mr_hydro(:,:,:,I_LSGRPL), &
    492                         sghydro%mr_hydro(:,:,:,I_CVRAIN),sghydro%mr_hydro(:,:,:,I_CVSNOW))
    493        endif
     538       
     539#ifdef MMF_V3p5_TWO_MOMENT
     540
     541        write(*,*) 'Precipitation Flux to Mixing Ratio conversion not (yet?) supported ', &
     542               'for MMF3.5 Two Moment Microphysics'
     543        stop
     544#else
     545            ! Density
     546            allocate(rho(Npoints,Nlevels))
     547            I_HYDRO = I_LSRAIN
     548            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., &
     549                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
     550                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
     551                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
     552                    gbx%rain_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
     553            I_HYDRO = I_LSSNOW
     554            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., &
     555                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
     556                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
     557                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
     558                    gbx%snow_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
     559            I_HYDRO = I_CVRAIN
     560            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., &
     561                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
     562                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
     563                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
     564                    gbx%rain_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
     565            I_HYDRO = I_CVSNOW
     566            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., &
     567                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
     568                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
     569                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
     570                    gbx%snow_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
     571            I_HYDRO = I_LSGRPL
     572            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., &
     573                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
     574                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
     575                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
     576                    gbx%grpl_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
     577            if(allocated(rho)) deallocate(rho)
     578#endif
     579
     580        endif
    494581   !++++++++++ CRM mode ++++++++++
    495582   else
     583      call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
    496584      sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro
    497585      sghydro%Reff(:,1,:,:) = gbx%Reff
     586      sghydro%Np(:,1,:,:) = gbx%Np      ! added by Roj with Quickbeam V3.0
     587     
    498588      !--------- Clouds -------
    499589      where ((gbx%dtau_s > 0.0))
    … …  
    502592   endif ! Ncolumns > 1
    503593 
    504    
    505594   !++++++++++ Simulator ++++++++++
    506     call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar)
     595!#ifdef RTTOV
     596!    call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
     597!#else
     598    call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     599!#endif
    507600
    508601    ! Deallocate subgrid arrays

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_constants.F90

    r2298 r2435  
    2828! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes
    2929! Oct 2008 - H. Chepfer       - Added PARASOL_NREFL
     30! Jun 2010 - R. Marchand      - Modified to support quickbeam V3, added ifdef for hydrometeor definitions
     31!
    3032!
    3133!
     34
     35#include "cosp_defs.h"
    3236MODULE MOD_COSP_CONSTANTS
     37
    3338    use netcdf, only: nf90_fill_real
    3439    IMPLICIT NONE
    35    
     40
     41    character(len=32) :: COSP_VERSION='COSP v1.4'
     42
    3643    ! Indices to address arrays of LS and CONV hydrometeors
    3744    integer,parameter :: I_LSCLIQ = 1
    … …  
    4451    integer,parameter :: I_CVSNOW = 8
    4552    integer,parameter :: I_LSGRPL = 9
    46    
     53
    4754    ! Missing value
    48 !!    real,parameter :: R_UNDEF = -1.0E30
    49 !     real,parameter :: R_UNDEF = 9.96921e+36
    50       real,parameter :: R_UNDEF = nf90_fill_real
     55    real,parameter :: R_UNDEF = -1.0E30
     56!    real,parameter :: R_UNDEF = nf90_fill_real
    5157
    5258    ! Number of possible output variables
    53     integer,parameter :: N_OUT_LIST = 27
     59    integer,parameter :: N_OUT_LIST = 63
     60    integer,parameter :: N3D = 8
     61    integer,parameter :: N2D = 14
     62    integer,parameter :: N1D = 40
     63
    5464    ! Value for forward model result from a level that is under the ground
    5565    real,parameter :: R_GROUND = -1.0E20
    … …  
    5868    integer, parameter :: I_LSC = 1, & ! Large-scale clouds
    5969                          I_CVC = 2    ! Convective clouds
    60    
     70
     71    ! Timing of different simulators, including statistics module
     72    integer, parameter :: N_SIMULATORS = 7
     73    integer,parameter :: I_RADAR = 1
     74    integer,parameter :: I_LIDAR = 2
     75    integer,parameter :: I_ISCCP = 3
     76    integer,parameter :: I_MISR  = 4
     77    integer,parameter :: I_MODIS = 5
     78    integer,parameter :: I_RTTOV = 6
     79    integer,parameter :: I_STATS = 7
     80    character*32, dimension(N_SIMULATORS) :: SIM_NAME = (/'Radar','Lidar','ISCCP','MISR ','MODIS','RTTOV','Stats'/)
     81    integer,dimension(N_SIMULATORS) :: tsim
     82    data tsim/N_SIMULATORS*0.0/
     83
    6184    !--- Radar constants
    6285    ! CFAD constants
    … …  
    6790    real,parameter    :: CFAD_ZE_WIDTH =    5.0 ! Bin width (dBZe)
    6891
    69    
     92
    7093    !--- Lidar constants
    7194    ! CFAD constants
    … …  
    7396    integer,parameter :: DPOL_BINS     =   6
    7497    real,parameter    :: LIDAR_UNDEF   =   999.999
     98
    7599    ! Other constants
    76100    integer,parameter :: LIDAR_NCAT    =   4
    77101    integer,parameter :: PARASOL_NREFL =   5 ! parasol
    78     real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 6.0, 80.0/)
    79 !    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/1.0, 2.0, 3.0, 4.0, 5.0/)
     102    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/)
    80103    real,parameter    :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius
    81    
     104
     105    integer,parameter :: LIDAR_NTEMP = 40
     106    real,parameter,dimension(LIDAR_NTEMP) :: LIDAR_PHASE_TEMP=(/-91.5,-88.5,-85.5,-82.5,-79.5,-76.5,-73.5,-70.5,-67.5,-64.5, &
     107                   -61.5,-58.5,-55.5,-52.5,-49.5,-46.5,-43.5,-40.5,-37.5,-34.5, &
     108                   -31.5,-28.5,-25.5,-22.5,-19.5,-16.5,-13.5,-10.5, -7.5, -4.5, &
     109                    -1.5,  1.5,  4.5,  7.5, 10.5, 13.5, 16.5, 19.5, 22.5, 25.5/)
     110    real,parameter,dimension(2,LIDAR_NTEMP) :: LIDAR_PHASE_TEMP_BNDS=reshape(source=(/-273.15,-90.,-90.,-87.,-87.,-84.,-84.,-81.,-81.,-78., &
     111                   -78.,-75.,-75.,-72.,-72.,-69.,-69.,-66.,-66.,-63., &
     112                   -63.,-60.,-60.,-57.,-57.,-54.,-54.,-51.,-51.,-48., &
     113                   -48.,-45.,-45.,-42.,-42.,-39.,-39.,-36.,-36.,-33., &
     114                   -33.,-30.,-30.,-27.,-27.,-24.,-24.,-21.,-21.,-18., &
     115                   -18.,-15.,-15.,-12.,-12., -9., -9., -6., -6., -3., &
     116                    -3.,  0.,  0.,  3.,  3.,  6.,  6.,  9.,  9., 12., &
     117                    12., 15., 15., 18., 18., 21., 21., 24., 24.,100./),shape=(/2,40/))
     118
    82119    !--- MISR constants
    83120    integer,parameter :: MISR_N_CTH = 16
    … …  
    85122    !--- RTTOV constants
    86123    integer,parameter :: RTTOV_MAX_CHANNELS = 20
    87    
     124
    88125    ! ISCCP tau-Pc axes
    89     real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 50000.0/)
     126    real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/)
    90127    real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, &
    91128                                                      9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/))
    92    
    93 !     real,parameter,dimension(7) :: ISCCP_PC = (/9000., 24500., 37500., 50000., 62000., 74000., 90000./)
    94 !     real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/0.0,18000.0,18000.0,31000.0,31000.0, &
    95 !                                44000.0,44000.0,56000.0,56000.0,68000.0,68000.0,80000.0,80000.0,100000.0/), shape=(/2,7/))
    96    
     129
    97130    real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./)
    98131    real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/100000.0,80000.0,80000.0,68000.0,68000.0,56000.0 &
    99132                               ,56000.0,44000.0,44000.0,31000.0,31000.0,18000.0,18000.0,0.0/), shape=(/2,7/))
    100    
    101     real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = (/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, &
     133
     134    real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = 1000.0*(/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, &
    102135                                            4.5, 6., 8., 10., 12., 14.5, 16., 18./)
    103     real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = reshape(source=(/ &
     136    real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = 1000.0*reshape(source=(/ &
    104137                                            -99.0,  0.0,       0.0,  0.5,       0.5,  1.0,      1.0,  1.5, &
    105138                                              1.5,  2.0,       2.0,  2.5,       2.5,  3.0,      3.0,  4.0, &
    … …  
    107140                                             11.0, 13.0,      13.0, 15.0,      15.0, 17.0,     17.0, 99.0/), &
    108141                                             shape=(/2,MISR_N_CTH/))
    109            
    110     !  Table hclass for quickbeam
     142
     143
     144    !
     145    ! The following code was modifed by Roj with implementation of quickbeam V3
     146    !   (1) use ifdef to support more than one microphyscis scheme
     147    !   (2) added constants  microphysic_scheme_name, LOAD_scale_LUTs, and SAVE_scale_LUTs
     148    !
     149
     150    ! directory where LUTs will be stored
     151    character*120 :: RADAR_SIM_LUT_DIRECTORY = './'
     152
     153#ifdef MMF_V3_SINGLE_MOMENT
     154
     155    !       
     156    !  Table hclass for quickbeam to support one-moment (bulk) microphysics scheme used by MMF V3.0 & V3.5
     157    !
     158
     159    !
     160    ! NOTE:  if ANY value in this section of code is changed, the existing LUT
     161    !        (i.e., the associated *.dat file) MUST be deleted so that a NEW
     162    !        LUT will be created !!!
     163    !
     164    character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3_single_moment'
     165
     166    logical :: RADAR_SIM_LOAD_scale_LUTs_flag   = .false.
     167    logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false.
    111168    integer,parameter :: N_HYDRO = 9
    112     real :: HCLASS_TYPE(N_HYDRO),HCLASS_COL(N_HYDRO),HCLASS_PHASE(N_HYDRO), &
    113             HCLASS_CP(N_HYDRO),HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO)
    114     real :: HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
     169
     170    integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO)
     171
     172    real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), &
     173            HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
    115174            HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO)
    116     data HCLASS_TYPE/5,1,2,2,5,1,2,2,2/
    117     data HCLASS_COL/1,2,3,4,5,6,7,8,9/
    118     data HCLASS_PHASE/0,1,0,1,0,1,0,1,1/
    119     data HCLASS_CP/0,0,1,1,0,0,1,1,1/
    120     data HCLASS_DMIN/-1,-1,-1,-1,-1,-1,-1,-1,-1/
    121     data HCLASS_DMAX/-1,-1,-1,-1,-1,-1,-1,-1,-1/
    122     data HCLASS_APM/524,110.8,524,-1,524,110.8,524,-1,-1/
    123     data HCLASS_BPM/3,2.91,3,-1,3,2.91,3,-1,-1/
    124     data HCLASS_RHO/-1,-1,-1,100,-1,-1,-1,100,400/
    125     data HCLASS_P1/-1,-1,8000000.,3000000.,-1,-1,8000000.,3000000.,4000000./
    126     data HCLASS_P2/6,40,-1,-1,6,40,-1,-1,-1/
    127     data HCLASS_P3/0.3,2,-1,-1,0.3,2,-1,-1,-1/
    128 
    129    
    130    
     175
     176    ! HCLASS_CP is not used in the version of Quickbeam included in COSP
     177    !                   LSL    LSI      LSR     LSS   CVL    CVI   CVR     CVS   LSG
     178    data HCLASS_TYPE/    5,      1,      2,      2,     5,     1,   2,      2,    2/
     179    data HCLASS_PHASE/   0,      1,      0,      1,     0,     1,   0,      1,    1/
     180    data HCLASS_DMIN/   -1,     -1,     -1,     -1,    -1,    -1,   -1,    -1,   -1/
     181    data HCLASS_DMAX/   -1,     -1,     -1,     -1,    -1,    -1,   -1,    -1,   -1/
     182    data HCLASS_APM/   524,  110.8,    524,     -1,   524, 110.8,  524,    -1,   -1/
     183    data HCLASS_BPM/     3,   2.91,      3,     -1,     3,  2.91,    3,    -1,   -1/
     184    data HCLASS_RHO/    -1,     -1,     -1,    100,    -1,    -1,   -1,   100,  400/
     185    data HCLASS_P1/     -1,     -1,   8.e6,   3.e6,    -1,    -1, 8.e6,  3.e6, 4.e6/
     186    data HCLASS_P2/      6,     40,     -1,      -1,    6,    40,   -1,    -1,   -1/
     187    data HCLASS_P3/    0.3,      2,     -1,      -1,  0.3,     2,   -1,    -1,   -1/
     188
     189    ! NOTES on HCLASS variables
     190    !
     191    ! TYPE - Set to
     192    ! 1 for modified gamma distribution,
     193    ! 2 for exponential distribution,
     194    ! 3 for power law distribution,
     195    ! 4 for monodisperse distribution,
     196    ! 5 for lognormal distribution.
     197
     198    ! PHASE - Set to 0 for liquid, 1 for ice.
     199
     200    ! DMIN - The minimum drop size for this class (micron), ignored for monodisperse.
     201    ! DMAX - The maximum drop size for this class (micron), ignored for monodisperse.
     202    ! Important note: The settings for DMIN and DMAX are
     203    ! ignored in the current version for all distributions except for power
     204    ! law. Except when the power law distribution is used, particle size
     205    ! is fixed to vary from zero to infinity, a restriction that is expected
     206    ! to be lifted in future versions. A placeholder must still be specified
     207    ! for each.
     208
     209    ! Density of particles is given by apm*D^bpm or a fixed value rho. ONLY specify ONE of these two!!
     210    ! APM - The alpha_m coefficient in equation (1) (kg m**-beta_m )
     211    ! BPM - The beta_m coefficient in equation (1), see section 4.1.
     212
     213    ! RHO - Hydrometeor density (kg m-3 ).
     214
     215    ! P1, P2, P3 - are default distribution parameters that depend on the type
     216    ! of distribution (see quickmbeam documentation for more information)
     217    !
     218    ! Modified Gamma (must set P3 and one of P1 or P2)
     219    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 ), where
     220    ! rho_a is the density of air in the radar volume.
     221    ! P2 - Set to the particle mean diameter D (micron).
     222    ! P3 - Set to the distribution width nu.
     223    !
     224    ! Exponetial (set one of)
     225    ! P1 - Set to a constant intercept parameter N0 (m-4).
     226    ! P2 - Set to a constant lambda (micron-1).
     227    !
     228    ! Power Law
     229    ! P1 - Set this to the value of a constant power law parameter br
     230    !
     231    ! Monodisperse
     232    ! P1 - Set to a constant diameter D0 (micron) = Re.
     233    !
     234    ! Log-normal (must set P3 and one of P1 or P2)
     235    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 )
     236    ! P2 - Set to the geometric mean particle radius rg (micron).
     237    ! P3 - Set to the natural logarithm of the geometric standard deviation.
     238    !
     239
     240
     241    real,dimension(N_HYDRO) :: N_ax,N_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma_1,gamma_2,gamma_3,gamma_4
     242
     243    ! Microphysical settings for the precipitation flux to mixing ratio conversion
     244    !                LSL    LSI       LSR       LSS   CVL    CVI       CVR       CVS      LSG
     245    data N_ax/       -1.,   -1.,     8.e6,     3.e6,  -1.,   -1.,     8.e6,     3.e6,     4.e6/
     246    data N_bx/       -1.,   -1.,      0.0,      0.0,  -1.,   -1.,      0.0,      0.0,      0.0/
     247    data alpha_x/    -1.,   -1.,      0.0,      0.0,  -1.,   -1.,      0.0,      0.0,      0.0/
     248    data c_x/        -1.,   -1.,    842.0,     4.84,  -1.,   -1.,    842.0,     4.84,     94.5/
     249    data d_x/        -1.,   -1.,      0.8,     0.25,  -1.,   -1.,      0.8,     0.25,      0.5/
     250    data g_x/        -1.,   -1.,      0.5,      0.5,  -1.,   -1.,      0.5,      0.5,      0.5/
     251    data a_x/        -1.,   -1.,    524.0,    52.36,  -1.,   -1.,    524.0,    52.36,   209.44/
     252    data b_x/        -1.,   -1.,      3.0,      3.0,  -1.,   -1.,      3.0,      3.0,      3.0/
     253    data gamma_1/    -1.,   -1., 17.83725, 8.284701,  -1.,   -1., 17.83725, 8.284701, 11.63230/
     254    data gamma_2/    -1.,   -1.,      6.0,      6.0,  -1.,   -1.,      6.0,      6.0,      6.0/
     255    data gamma_3/    -1.,   -1.,      2.0,      2.0,  -1.,   -1.,      2.0,      2.0,      2.0/
     256    data gamma_4/    -1.,   -1.,      6.0,      6.0,  -1.,   -1.,      6.0,      6.0,      6.0/
     257
     258
     259
     260#endif
     261
     262
     263#ifdef MMF_V3p5_TWO_MOMENT
     264
     265    !
     266    !  Table hclass for quickbeam to support two-moment "morrison" microphysics scheme used by V3.5 (SAM 6.8)
     267    !
     268    !  This Number concentriation Np in [1/kg] MUST be input to COSP/radar simulator
     269    !
     270    !  NOTE:  Be sure to check that the ice-density (rho) set it this tables matches what you used
     271    !
     272
     273    !
     274    ! NOTE:  if ANY value in this section of code is changed, the existing LUT
     275    !        (i.e., the associated *.dat file) MUST be deleted so that a NEW
     276    !        LUT will be created !!!
     277    !
     278    character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3.5_two_moment'
     279
     280    logical :: RADAR_SIM_LOAD_scale_LUTs_flag   = .false.
     281    logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false.
     282
     283    integer,parameter :: N_HYDRO = 9
     284
     285    integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO)
     286
     287    real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), &           
     288            HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
     289            HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO)
     290
     291    ! HCLASS_CP is not used in the version of Quickbeam included in COSP
     292    !                   LSL    LSI      LSR     LSS   CVL    CVI   CVR     CVS   LSG
     293    data HCLASS_TYPE/    1,      1,      1,      1,     1,     1,    1,      1,    1/
     294    data HCLASS_PHASE/   0,      1,      0,      1,     0,     1,    0,      1,    1/
     295    data HCLASS_DMIN/   -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
     296    data HCLASS_DMAX/   -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
     297    data HCLASS_APM/   524,     -1,    524,     -1,   524,    -1,  524,     -1,   -1/
     298    data HCLASS_BPM/     3,     -1,      3,     -1,     3,    -1,    3,     -1,   -1/
     299    data HCLASS_RHO/    -1,    500,     -1,    100,    -1,   500,   -1,    100,  900/
     300    data HCLASS_P1/     -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
     301    data HCLASS_P2/     -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
     302    data HCLASS_P3/     -2,      1,      1,      1,    -2,     1,    1,      1,    1/
     303    ! Note: value of "-2" for HCLASS_P3 uses martin 1994 parameteriztion of gamma function width with Number concentration
     304#endif
     305
    131306END MODULE MOD_COSP_CONSTANTS

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_isccp_simulator.F90

    r2298 r2435  
    11! (c) British Crown Copyright 2008, the Met Office.
    22! All rights reserved.
     3! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_isccp_simulator.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    4244 
    4345  ! Local variables
    44   integer :: i,Nlevels,Npoints
     46  integer :: Nlevels,Npoints
    4547  real :: pfull(gbx%Npoints, gbx%Nlevels)
    4648  real :: phalf(gbx%Npoints, gbx%Nlevels + 1)
    … …  
    8486  y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1)
    8587     
    86   ! Change boxptop from hPa to Pa. This avoids using UDUNITS in CMOR
    87 !  y%boxptop = y%boxptop*100.0
    88  
     88 
    8989  ! Check if there is any value slightly greater than 1
    9090  where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5))

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_lidar.F90

    r2298 r2435  
    11! (c) British Crown Copyright 2008, the Met Office.
    22! All rights reserved.
     3! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_lidar.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    2931!                               Call lidar_simulator changed (lsca, gbx%cca and depol removed;
    3032!                               frac_out changed in sgx%frac_out)
     33! Jun 2011 - G. Cesana        - Added betaperp_tot argument
    3134!
    3235!
    … …  
    4346!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    4447SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y)
    45  
     48
    4649  ! Arguments
    4750  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
    … …  
    4952  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
    5053  type(cosp_sglidar),intent(inout) :: y ! Subgrid output
    51  
     54
    5255  ! Local variables
    5356  integer :: i
    5457  real :: presf(sgx%Npoints, sgx%Nlevels + 1)
    55   real :: frac_out(sgx%Npoints, sgx%Nlevels)
    5658  real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci
    5759  real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot
     60  real,dimension(sgx%Npoints, sgx%Nlevels) :: betaperp_tot
    5861  real,dimension(sgx%Npoints, PARASOL_NREFL)  :: refle
    59  
    60  
     62
    6163  presf(:,1:sgx%Nlevels) = gbx%ph
    6264  presf(:,sgx%Nlevels + 1) = 0.0
    63 !   presf(:,sgx%Nlevels + 1) = gbx%p(:,sgx%Nlevels) - (presf(:,sgx%Nlevels) - gbx%p(:,sgx%Nlevels))
    6465  lsca = gbx%tca-gbx%cca
    6566  do i=1,sgx%Ncolumns
    … …  
    6970      mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ)
    7071      mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE)
    71       frac_out(:,:) = sgx%frac_out(:,i,:)   
    72       call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4 &
    73                  , PARASOL_NREFL, LIDAR_UNDEF  &
    74                  , gbx%p, presf, gbx%T &
    75                  , mr_ll, mr_li, mr_cl, mr_ci &
    76                  , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE), gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
    77                  , frac_out, gbx%lidar_ice_type, y%beta_mol, beta_tot, tau_tot  &
    78                  , refle ) ! reflectance
    79      
     72      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4, PARASOL_NREFL, LIDAR_UNDEF  &
     73                 , gbx%p, presf, gbx%T, mr_ll, mr_li, mr_cl, mr_ci &
     74                 , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE) &
     75                 , gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
     76                 , gbx%lidar_ice_type, y%beta_mol, beta_tot &
     77                 , betaperp_tot, tau_tot, refle )
     78
     79      y%betaperp_tot(:,i,:) = betaperp_tot(:,:)
    8080      y%beta_tot(:,i,:) = beta_tot(:,:)
    8181      y%tau_tot(:,i,:)  = tau_tot(:,:)

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_misr_simulator.F90

    r2298 r2435  
    11! (c) British Crown Copyright 2008, the Met Office.
    22! All rights reserved.
     3! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_misr_simulator.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    4850 
    4951  ! Local variables
    50   integer :: i,Nlevels,Npoints
     52  integer :: Nlevels,Npoints
    5153  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
    5254  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
    … …  
    5860                                          !  zfull(npoints,1)    is    top level of model
    5961                                          !  zfull(npoints,nlev) is bottom level of model
    60   real :: phy_t0p1_mean_ztop              ! mean cloud top height(m) of 0.1 tau treshold
    61   real :: fq_phy_t0p1_TAU_v_CTH(7,16)     
    6262     
    63        
     63   
    6464  Nlevels = gbx%Nlevels
    6565  Npoints = gbx%Npoints
    … …  
    7373 
    7474  call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,&
    75                      sunlit,zfull,at,dtau_s,dtau_c,frac_out, &
     75                     sunlit,zfull,at,dtau_s,dtau_c,frac_out, R_UNDEF, &
    7676                     y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea)
    7777           

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_mod.F90

    r2408 r2435  
    88  USE MOD_COSP_CONSTANTS
    99  USE MOD_COSP_TYPES
     10  use MOD_COSP_Modis_Simulator, only : cosp_modis
    1011
    1112! cosp_output_mod
    … …  
    1516      INTEGER, DIMENSION(3), SAVE  :: cosp_nidfiles
    1617!$OMP THREADPRIVATE(cosp_outfilekeys, cosp_nidfiles)
    17       INTEGER, DIMENSION(3), SAVE  :: nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp
     18      INTEGER, DIMENSION(3), SAVE  :: nhoricosp,nvert,nvertmcosp,nvertcol,nvertisccp,nvertp,nverttemp,nvertmisr
    1819      REAL, DIMENSION(3), SAVE                :: zoutm_cosp
    19 !$OMP THREADPRIVATE(nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp, zoutm_cosp)
     20!$OMP THREADPRIVATE(nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp, zoutm_cosp, nverttemp, nvertmisr)
    2021      REAL, SAVE                   :: zdtimemoy_cosp
    2122!$OMP THREADPRIVATE(zdtimemoy_cosp)
    … …  
    3334     CHARACTER(len=20),DIMENSION(3)  :: cosp_typeecrit        !!! Operation (ave, inst, ...)
    3435  END TYPE ctrl_outcosp
     36
    3537! CALIPSO vars
    3638  TYPE(ctrl_outcosp), SAVE :: o_cllcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
    37          "cllcalipso", "Lidar Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /))                                   
     39         "cllcalipso", "Lidar Low-level Cloud Fraction", "%", (/ ('', i=1, 3) /))                                   
    3840  TYPE(ctrl_outcosp), SAVE :: o_clmcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
    39          "clmcalipso", "Lidar Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
     41         "clmcalipso", "Lidar Mid-level Cloud Fraction", "%", (/ ('', i=1, 3) /))
    4042  TYPE(ctrl_outcosp), SAVE :: o_clhcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
    41          "clhcalipso", "Lidar Hight-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
     43         "clhcalipso", "Lidar Hight-level Cloud Fraction", "%", (/ ('', i=1, 3) /))
    4244  TYPE(ctrl_outcosp), SAVE :: o_cltcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
    43          "cltcalipso", "Lidar Total Cloud Fraction", "1", (/ ('', i=1, 3) /))
     45         "cltcalipso", "Lidar Total Cloud Fraction", "%", (/ ('', i=1, 3) /))
    4446  TYPE(ctrl_outcosp), SAVE :: o_clcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
    45          "clcalipso", "Lidar Cloud Fraction (532 nm)", "1", (/ ('', i=1, 3) /))
     47         "clcalipso", "Lidar Cloud Fraction (532 nm)", "%", (/ ('', i=1, 3) /))
    4648  TYPE(ctrl_outcosp), SAVE :: o_cfad_lidarsr532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
    4749         "cfad_lidarsr532", "Lidar Scattering Ratio CFAD (532 nm)", "1", (/ ('', i=1, 3) /))   
    … …  
    5658  TYPE(ctrl_outcosp), SAVE :: o_beta_mol532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
    5759         "beta_mol532", "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /))
     60!! AI  11 2015
     61  TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     62         "cllcalipsoice", "CALIPSO Ice-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) 
     63  TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     64         "cllcalipsoliq", "CALIPSO Liq-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     65  TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     66         "clmcalipsoice", "CALIPSO Ice-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     67  TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     68         "clmcalipsoliq", "CALIPSO Liq-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /))                 
     69  TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     70         "clhcalipsoice", "CALIPSO Ice-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) 
     71  TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     72         "clhcalipsoliq", "CALIPSO Liq-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     73  TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     74         "cltcalipsoice", "CALIPSO Ice-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     75  TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     76         "cltcalipsoliq", "CALIPSO Liq-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /))                 
     77  TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     78         "cllcalipsoun", "CALIPSO Undefined-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) 
     79  TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     80         "clmcalipsoun", "CALIPSO Undefined-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     81  TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     82         "clhcalipsoun", "CALIPSO Undefined-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     83  TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     84         "cltcalipsoun", "CALIPSO Undefined-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
     85  TYPE(ctrl_outcosp), SAVE :: o_clcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     86         "clcalipsoice", "Lidar Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
     87  TYPE(ctrl_outcosp), SAVE :: o_clcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     88         "clcalipsoliq", "Lidar Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
     89  TYPE(ctrl_outcosp), SAVE :: o_clcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     90         "clcalipsoun", "Lidar Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))     
     91  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     92         "clcalipsotmpice", "Lidar Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
     93  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     94         "clcalipsotmpliq", "Lidar Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
     95  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     96         "clcalipsotmpun", "Lidar Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
     97  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     98         "clcalipsotmp", "Lidar Cloud Fraction", "%", (/ ('', i=1, 3) /))
     99
     100! Radar Cloudsat
     101  TYPE(ctrl_outcosp), SAVE :: o_cfadDbze94 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     102         "cfadDbze94", "CloudSat Radar Reflectivity CFAD", "%", (/ ('', i=1, 3) /))
     103  TYPE(ctrl_outcosp), SAVE :: o_dbze94 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     104         "dbze94", "CloudSat Radar Reflectivity", "%", (/ ('', i=1, 3) /))
     105
     106! Calipso + Cloudsat
     107  TYPE(ctrl_outcosp), SAVE :: o_clcalipso2 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     108         "clcalipso2", "CALIPSO Cloud Fraction Undetected by CloudSat", "1", (/ ('', i=1, 3) /))
     109
    58110! ISCCP vars
    59111  TYPE(ctrl_outcosp), SAVE :: o_sunlit = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
    … …  
    80132           by the ISCCP Simulator","K", (/ ('', i=1, 3) /))
    81133
     134! MISR simulator
     135  TYPE(ctrl_outcosp), SAVE :: o_clMISR = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     136         "clMISR", "Cloud Fraction as Calculated by the MISR Simulator","1", (/ ('', i=1, 3) /))
     137
     138! MODIS simulator
     139  TYPE(ctrl_outcosp), SAVE :: o_cllmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     140         "cllmodis", "MODIS Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /))                                   
     141  TYPE(ctrl_outcosp), SAVE :: o_clmmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     142         "clmmodis", "MODIS Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
     143  TYPE(ctrl_outcosp), SAVE :: o_clhmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     144         "clhmodis", "MODIS Hight-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
     145  TYPE(ctrl_outcosp), SAVE :: o_cltmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     146         "cltmodis", "MODIS Total Cloud Fraction", "1", (/ ('', i=1, 3) /))
     147  TYPE(ctrl_outcosp), SAVE :: o_clwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     148         "clwmodis", "MODIS Cloud Fraction water mean", "1", (/ ('', i=1, 3) /))
     149  TYPE(ctrl_outcosp), SAVE :: o_climodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     150         "climodis", "MODIS Cloud Fraction ice mean", "1", (/ ('', i=1, 3) /)) 
     151  TYPE(ctrl_outcosp), SAVE :: o_tautmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     152         "tautmodis", "MODIS Optical_Thickness_Total_Mean", "1", (/ ('', i=1, 3) /))                                   
     153  TYPE(ctrl_outcosp), SAVE :: o_tauwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     154         "tauwmodis", "MODIS Optical_Thickness_Water_Mean", "1", (/ ('', i=1, 3) /))
     155  TYPE(ctrl_outcosp), SAVE :: o_tauimodis= ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     156         "tauimodis", "MODIS Optical_Thickness_Ice_Mean", "1", (/ ('', i=1, 3) /))
     157  TYPE(ctrl_outcosp), SAVE :: o_tautlogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     158         "tautlogmodis", "MODIS Optical_Thickness_Total_logMean", "1", (/ ('', i=1, 3) /))                                   
     159  TYPE(ctrl_outcosp), SAVE :: o_tauwlogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     160         "tauwlogmodis", "MODIS Optical_Thickness_Water_logMean", "1", (/ ('', i=1, 3) /))
     161  TYPE(ctrl_outcosp), SAVE :: o_tauilogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     162         "tauilogmodis", "MODIS Optical_Thickness_Ice_logMean", "1", (/ ('', i=1, 3) /))         
     163  TYPE(ctrl_outcosp), SAVE :: o_reffclwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     164         "reffclwmodis", "Modis Cloud_Particle_Size_Water_Mean", "m", (/ ('', i=1, 3) /))               
     165  TYPE(ctrl_outcosp), SAVE :: o_reffclimodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     166         "reffclimodis", "Modis Cloud_Particle_Size_Ice_Mean", "m", (/ ('', i=1, 3) /))
     167  TYPE(ctrl_outcosp), SAVE :: o_pctmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     168         "pctmodis", "Modis Cloud_Top_Pressure_Total_Mean", "Pa", (/ ('', i=1, 3) /))
     169  TYPE(ctrl_outcosp), SAVE :: o_lwpmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     170         "lwpmodis", "Modis Liquid_Water_Path_Mean", "kg m-2", (/ ('', i=1, 3) /))
     171  TYPE(ctrl_outcosp), SAVE :: o_iwpmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     172         "iwpmodis", "Modis Ice_Water_Path_Mean", "kg m-2", (/ ('', i=1, 3) /)) 
     173  TYPE(ctrl_outcosp), SAVE :: o_clmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     174         "clmodis", "MODIS Cloud Area Fraction", "%", (/ ('', i=1, 3) /))
     175
     176! Rttovs simulator
     177  TYPE(ctrl_outcosp), SAVE :: o_tbrttov = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     178         "tbrttov", "Rttovs Cloud Area Fraction", "%", (/ ('', i=1, 3) /))
     179
     180! Scops and others
     181  TYPE(ctrl_outcosp), SAVE :: o_fracout = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
     182         "fracout", "Subcolumn output from SCOPS", "%", (/ ('', i=1, 3) /))     
     183
    82184  LOGICAL, SAVE :: cosp_varsdefined = .FALSE. ! ug PAS THREADPRIVATE ET C'EST NORMAL
    83185  REAL, SAVE  :: Cosp_fill_value
    … …  
    181283          Cosp_fill_value=0.
    182284         print*,'Cosp_fill_value=',Cosp_fill_value
    183     ! ug R\'eglage du calendrier xios
    184     !Temps julian => an, mois, jour, heure
    185 !    CALL ju2ymds(zjulian, x_an, x_mois, x_jour, x_heure)
    186 !    CALL ju2ymds(zjulian_start, ini_an, ini_mois, ini_jour, ini_heure)
    187 !    CALL wxios_set_cal(dtime, calend, x_an, x_mois, x_jour, x_heure, ini_an, &
    188 !                       ini_mois, ini_jour, ini_heure )
    189        ! ug d�claration des axes verticaux de chaque fichier:
    190285!    if (use_vgrid) then
     286!      print*,'vgrid%Nlvgrid, vgrid%z = ',vgrid%Nlvgrid, vgrid%z
    191287        CALL wxios_add_vaxis("height", vgrid%Nlvgrid, vgrid%z)
     288     print*,'wxios_add_vaxis '
    192289!    else
    193290!         WRITE(lunout,*) 'wxios_add_vaxis "presnivs", vgrid%Nlvgrid ',vgrid%Nlvgrid
    … …  
    202299    WRITE(lunout,*) 'wxios_add_vaxis column ',Ncolumns
    203300    CALL wxios_add_vaxis("column", Ncolumns, column_ax)
     301
     302! AI nov 2015
     303   CALL wxios_add_vaxis("temp", LIDAR_NTEMP, LIDAR_PHASE_TEMP)
     304   CALL wxios_add_vaxis("cth16", MISR_N_CTH, MISR_CTH)
    204305#endif
    205306   
    … …  
    212313           CALL histbeg_phy_all(cosp_outfilenames(iff),itau_phy,zjulian,&
    213314             dtime,nhoricosp(iff),cosp_nidfiles(iff))
    214            print*,'histbeg_phy nhoricosp(iff),cosp_nidfiles(iff)', &
    215                     nhoricosp(iff),cosp_nidfiles(iff)
     315!           print*,'histbeg_phy nhoricosp(iff),cosp_nidfiles(iff)', &
     316!                    nhoricosp(iff),cosp_nidfiles(iff)
    216317
    217318#ifdef CPP_XIOS
    … …  
    240341      CALL histvert(cosp_nidfiles(iff),"column","column","count",Ncolumns,column_ax(1:Ncolumns),nvertcol(iff))
    241342
     343      CALL histvert(cosp_nidfiles(iff),"temp","temperature","C",LIDAR_NTEMP,LIDAR_PHASE_TEMP,nverttemp(iff))                                       
     344      CALL histvert(cosp_nidfiles(iff),"cth16","altitude","m",MISR_N_CTH,MISR_CTH,nvertmisr(iff))                                                                                                 
    242345!!! Valeur indefinie en cas IOIPSL
    243346     Cosp_fill_value=0.

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_output_write_mod.F90

    r2408 r2435  
    1818
    1919  SUBROUTINE cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
    20                                cfg, gbx, vgrid, sglidar, stlidar, isccp)
     20                               cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, &
     21                               isccp, misr, modis)
    2122
    2223    USE ioipsl
    … …  
    3536  type(cosp_gridbox)    :: gbx     ! Gridbox information. Input for COSP
    3637  type(cosp_sglidar)    :: sglidar ! Output from lidar simulator
     38  type(cosp_sgradar)    :: sgradar ! Output from radar simulator
    3739  type(cosp_isccp)      :: isccp   ! Output from ISCCP simulator
    3840  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
     41  type(cosp_radarstats) :: stradar
     42  type(cosp_misr)       :: misr    ! Output from MISR
     43  type(cosp_modis)      :: modis   ! Outputs from Modis
    3944  type(cosp_vgrid)      :: vgrid   ! Information on vertical grid of stats
    4045
    … …  
    126131   enddo
    127132
     133! AI 11 / 2015
     134
     135   where(stlidar%parasolrefl == R_UNDEF) stlidar%parasolrefl = 0.0
     136   where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = 0.0
     137   where(stlidar%cldlayerphase == R_UNDEF) stlidar%cldlayerphase = 0.0
     138   where(stlidar%lidarcldphase == R_UNDEF) stlidar%lidarcldphase = 0.0
     139   where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = 0.0
     140   
     141
    128142   print*,'Appel histwrite2d_cosp'
    129143   CALL histwrite2d_cosp(o_cllcalipso,stlidar%cldlayer(:,1))
    … …  
    132146   CALL histwrite2d_cosp(o_cltcalipso,stlidar%cldlayer(:,4))
    133147   CALL histwrite3d_cosp(o_clcalipso,stlidar%lidarcld,nvert)
     148   CALL histwrite3d_cosp(o_clcalipsotmp,stlidar%lidarcldtmp(:,:,1),nverttemp)
     149
     150   CALL histwrite2d_cosp(o_cllcalipsoice,stlidar%cldlayerphase(:,1,1))
     151   CALL histwrite2d_cosp(o_clhcalipsoice,stlidar%cldlayerphase(:,3,1))
     152   CALL histwrite2d_cosp(o_clmcalipsoice,stlidar%cldlayerphase(:,2,1))
     153   CALL histwrite2d_cosp(o_cltcalipsoice,stlidar%cldlayerphase(:,4,1))
     154   CALL histwrite3d_cosp(o_clcalipsoice,stlidar%lidarcldphase(:,:,1),nvert)
     155   CALL histwrite3d_cosp(o_clcalipsotmpice,stlidar%lidarcldtmp(:,:,2),nverttemp)
     156
     157   CALL histwrite2d_cosp(o_cllcalipsoliq,stlidar%cldlayerphase(:,1,2))
     158   CALL histwrite2d_cosp(o_clhcalipsoliq,stlidar%cldlayerphase(:,3,2))
     159   CALL histwrite2d_cosp(o_clmcalipsoliq,stlidar%cldlayerphase(:,2,2))
     160   CALL histwrite2d_cosp(o_cltcalipsoliq,stlidar%cldlayerphase(:,4,2))
     161   CALL histwrite3d_cosp(o_clcalipsoliq,stlidar%lidarcldphase(:,:,2),nvert)
     162   CALL histwrite3d_cosp(o_clcalipsotmpliq,stlidar%lidarcldtmp(:,:,3),nverttemp)
     163
     164   CALL histwrite2d_cosp(o_cllcalipsoun,stlidar%cldlayerphase(:,1,3))
     165   CALL histwrite2d_cosp(o_clhcalipsoun,stlidar%cldlayerphase(:,3,3))
     166   CALL histwrite2d_cosp(o_clmcalipsoun,stlidar%cldlayerphase(:,2,3))
     167   CALL histwrite2d_cosp(o_cltcalipsoun,stlidar%cldlayerphase(:,4,3))
     168   CALL histwrite3d_cosp(o_clcalipsoice,stlidar%lidarcldphase(:,:,3),nvert)
     169   CALL histwrite3d_cosp(o_clcalipsotmpun,stlidar%lidarcldtmp(:,:,4),nverttemp)
    134170
    135171   do icl=1,SR_BINS
    … …  
    160196 endif !Lidar
    161197
     198 if (cfg%Lradar_sim) then
     199   do icl=1,Ncolumns
     200      CALL histwrite3d_cosp(o_dbze94,sgradar%Ze_tot(:,icl,:),nvertmcosp,icl)
     201   enddo
     202   do icl=1,DBZE_BINS
     203    CALL histwrite3d_cosp(o_cfadDbze94,stradar%cfad_ze(:,icl,:),nvert,icl)
     204   enddo
     205 endif
     206
     207 if (cfg%Llidar_sim .and. cfg%Lradar_sim) then
     208   where(stradar%lidar_only_freq_cloud == R_UNDEF) &
     209                           stradar%lidar_only_freq_cloud = 0.0
     210   CALL histwrite3d_cosp(o_clcalipso2,stradar%lidar_only_freq_cloud,nvert)
     211 endif
     212
    162213 if (cfg%Lisccp_sim) then
    163214
    164215! Traitement des valeurs indefinies
    165216   do ip = 1,Npoints
    166     if(isccp%totalcldarea(ip).eq.-1.E+30)then
     217    if(isccp%totalcldarea(ip).eq.R_UNDEF)then
    167218      isccp%totalcldarea(ip)=Cosp_fill_value
    168219    endif
    169     if(isccp%meanptop(ip).eq.-1.E+30)then
     220    if(isccp%meanptop(ip).eq.R_UNDEF)then
    170221      isccp%meanptop(ip)=Cosp_fill_value
    171222    endif
    172     if(isccp%meantaucld(ip).eq.-1.E+30)then
     223    if(isccp%meantaucld(ip).eq.R_UNDEF)then
    173224      isccp%meantaucld(ip)=Cosp_fill_value
    174225    endif
    175     if(isccp%meanalbedocld(ip).eq.-1.E+30)then
     226    if(isccp%meanalbedocld(ip).eq.R_UNDEF)then
    176227      isccp%meanalbedocld(ip)=Cosp_fill_value
    177228    endif
    178     if(isccp%meantb(ip).eq.-1.E+30)then
     229    if(isccp%meantb(ip).eq.R_UNDEF)then
    179230      isccp%meantb(ip)=Cosp_fill_value
    180231    endif
    181     if(isccp%meantbclr(ip).eq.-1.E+30)then
     232    if(isccp%meantbclr(ip).eq.R_UNDEF)then
    182233      isccp%meantbclr(ip)=Cosp_fill_value
    183234    endif
    … …  
    185236    do k=1,7
    186237     do ii=1,7
    187      if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then
     238     if(isccp%fq_isccp(ip,ii,k).eq.R_UNDEF)then
    188239      isccp%fq_isccp(ip,ii,k)=Cosp_fill_value
    189240     endif
    … …  
    192243
    193244    do ii=1,Ncolumns
    194      if(isccp%boxtau(ip,ii).eq.-1.E+30)then
     245     if(isccp%boxtau(ip,ii).eq.R_UNDEF)then
    195246       isccp%boxtau(ip,ii)=Cosp_fill_value
    196247     endif
    … …  
    198249
    199250    do ii=1,Ncolumns
    200      if(isccp%boxptop(ip,ii).eq.-1.E+30)then
     251     if(isccp%boxptop(ip,ii).eq.R_UNDEF)then
    201252       isccp%boxptop(ip,ii)=Cosp_fill_value
    202253     endif
    … …  
    217268   CALL histwrite2d_cosp(o_meantbclrisccp,isccp%meantbclr)
    218269 endif ! Isccp
     270
     271! MISR simulator
     272 if (cfg%Lmisr_sim) then
     273   do ip=1,Npoints
     274     do ii=1,7
     275       do k=1,MISR_N_CTH
     276        if(misr%fq_MISR(ip,ii,k).eq.R_UNDEF)then
     277              misr%fq_MISR(ip,ii,k)=Cosp_fill_value
     278        endif
     279       enddo
     280     enddo
     281   enddo
     282
     283   do icl=1,7
     284      CALL histwrite3d_cosp(o_clMISR,misr%fq_MISR(:,icl,:),nvertmisr,icl)
     285   enddo
     286 endif
     287
     288! Modis simulator
     289 if (cfg%Lmodis_sim) then
     290
     291  do ip=1,Npoints
     292    if(modis%Cloud_Fraction_Low_Mean(ip).eq.R_UNDEF)then
     293       modis%Cloud_Fraction_Low_Mean(ip)=Cosp_fill_value
     294    endif
     295    if(modis%Cloud_Fraction_High_Mean(ip).eq.R_UNDEF)then
     296       modis%Cloud_Fraction_High_Mean(ip)=Cosp_fill_value
     297    endif
     298    if(modis%Cloud_Fraction_Mid_Mean(ip).eq.R_UNDEF)then
     299       modis%Cloud_Fraction_Mid_Mean(ip)=Cosp_fill_value
     300    endif
     301    if(modis%Cloud_Fraction_Total_Mean(ip).eq.R_UNDEF)then
     302       modis%Cloud_Fraction_Total_Mean(ip)=Cosp_fill_value
     303    endif
     304    if(modis%Cloud_Fraction_Water_Mean(ip).eq.R_UNDEF)then
     305       modis%Cloud_Fraction_Water_Mean(ip)=Cosp_fill_value
     306    endif
     307    if(modis%Cloud_Fraction_Ice_Mean(ip).eq.R_UNDEF)then
     308       modis%Cloud_Fraction_Ice_Mean(ip)=Cosp_fill_value
     309    endif
     310    if(modis%Optical_Thickness_Total_Mean(ip).eq.R_UNDEF)then
     311       modis%Optical_Thickness_Total_Mean(ip)=Cosp_fill_value
     312    endif
     313    if(modis%Optical_Thickness_Water_Mean(ip).eq.R_UNDEF)then
     314       modis%Optical_Thickness_Water_Mean(ip)=Cosp_fill_value
     315    endif
     316    if(modis%Optical_Thickness_Ice_Mean(ip).eq.R_UNDEF)then
     317       modis%Optical_Thickness_Ice_Mean(ip)=Cosp_fill_value
     318    endif
     319    if(modis%Cloud_Particle_Size_Water_Mean(ip).eq.R_UNDEF)then
     320       modis%Cloud_Particle_Size_Water_Mean(ip)=Cosp_fill_value
     321    endif
     322    if(modis%Cloud_Top_Pressure_Total_Mean(ip).eq.R_UNDEF)then
     323       modis%Cloud_Top_Pressure_Total_Mean(ip)=Cosp_fill_value
     324    endif
     325    if(modis%Liquid_Water_Path_Mean(ip).eq.R_UNDEF)then
     326       modis%Liquid_Water_Path_Mean(ip)=Cosp_fill_value
     327    endif
     328    if(modis%Ice_Water_Path_Mean(ip).eq.R_UNDEF)then
     329       modis%Ice_Water_Path_Mean(ip)=Cosp_fill_value
     330    endif
     331
     332  enddo
     333   
     334   CALL histwrite2d_cosp(o_cllmodis,modis%Cloud_Fraction_Low_Mean)
     335   CALL histwrite2d_cosp(o_clhmodis,modis%Cloud_Fraction_High_Mean)
     336   CALL histwrite2d_cosp(o_clmmodis,modis%Cloud_Fraction_Mid_Mean)
     337   CALL histwrite2d_cosp(o_cltmodis,modis%Cloud_Fraction_Total_Mean)
     338   CALL histwrite2d_cosp(o_clwmodis,modis%Cloud_Fraction_Water_Mean)
     339   CALL histwrite2d_cosp(o_climodis,modis%Cloud_Fraction_Ice_Mean)
     340   CALL histwrite2d_cosp(o_tautmodis,modis%Optical_Thickness_Total_Mean)
     341   CALL histwrite2d_cosp(o_tauwmodis,modis%Optical_Thickness_Water_Mean)
     342   CALL histwrite2d_cosp(o_tauimodis,modis%Optical_Thickness_Ice_Mean)
     343   CALL histwrite2d_cosp(o_tautlogmodis,modis%Optical_Thickness_Total_LogMean) 
     344   CALL histwrite2d_cosp(o_tauwlogmodis,modis%Optical_Thickness_Water_LogMean)
     345   CALL histwrite2d_cosp(o_tauilogmodis,modis%Optical_Thickness_Ice_LogMean)
     346   CALL histwrite2d_cosp(o_reffclwmodis,modis%Cloud_Particle_Size_Water_Mean)
     347   CALL histwrite2d_cosp(o_reffclimodis,modis%Cloud_Particle_Size_Ice_Mean)
     348   CALL histwrite2d_cosp(o_pctmodis,modis%Cloud_Top_Pressure_Total_Mean)
     349   CALL histwrite2d_cosp(o_lwpmodis,modis%Liquid_Water_Path_Mean)
     350   CALL histwrite2d_cosp(o_iwpmodis,modis%Ice_Water_Path_Mean)
     351
     352   do ip=1,Npoints
     353     do ii=1,7
     354       do k=1,7
     355       if(modis%Optical_Thickness_vs_Cloud_Top_Pressure(ip,ii,k).eq.R_UNDEF)then
     356          modis%Optical_Thickness_vs_Cloud_Top_Pressure(ip,ii,k)=0.
     357        endif
     358       enddo
     359     enddo
     360    enddo
     361
     362   do icl=1,7
     363   CALL histwrite3d_cosp(o_clmodis, &
     364     modis%Optical_Thickness_vs_Cloud_Top_Pressure(:,icl,:),nvertisccp,icl)           
     365   enddo
     366 endif
    219367
    220368 IF(.NOT.cosp_varsdefined) THEN
    … …  
    362510          klevs=Ncolout
    363511          nam_axvert="column"
     512      ELSE IF (nvertsave.eq.nverttemp(iff)) THEN
     513          klevs=LIDAR_NTEMP
     514          nam_axvert="temp"
     515      ELSE IF (nvertsave.eq.nvertmisr(iff)) THEN
     516          klevs=MISR_N_CTH
     517           nam_axvert="cth16"
    364518      ELSE
    365519           klevs=Nlevout
    … …  
    494648#ifdef CPP_XIOS
    495649      IF (ok_all_xml) THEN
    496         if (prt_level >= 10) then
     650        if (prt_level >= 1) then
    497651              WRITE(lunout,*)'xios_send_field variable ',var%name
    498652        endif
    … …  
    596750    IF (ok_all_xml) THEN
    597751     CALL xios_send_field(nom, Field3d(:,:,1:nlev))
    598      IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
     752     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
    599753    ENDIF
    600754#endif

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_radar.F90

    r2298 r2435  
    2626  USE MOD_COSP_CONSTANTS
    2727  USE MOD_COSP_TYPES
     28  USE MOD_COSP_UTILS
    2829  use radar_simulator_types
    2930  use array_lib
    … …  
    3132  use format_input
    3233  IMPLICIT NONE
    33  
     34
    3435  INTERFACE
    35     subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
    36         nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, &
    37         rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, &
     36    subroutine radar_simulator(hp,nprof,ngate,undef, &
     37        hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
     38        p_matrix,t_matrix,rh_matrix, &
     39        Ze_non,Ze_ray,g_to_vol,a_to_vol,dBZe, &
    3840        g_to_vol_in,g_to_vol_out)
    39  
    40         use m_mrgrnk 
     41
     42        use m_mrgrnk
    4143        use array_lib
    4244        use math_lib
    … …  
    4446        use radar_simulator_types
    4547        implicit none
     48
    4649        ! ----- INPUTS ----- 
    47         type(mie), intent(in) :: mt
    4850        type(class_param) :: hp
    49         real*8, intent(in) :: freq,k2
    50         integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
    51             nhclass,nprof,ngate,nsizes
    52         real*8, dimension(nsizes), intent(in) :: D
     51
     52        integer, intent(in) :: nprof,ngate
     53
     54        real undef
    5355        real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
    5456            t_matrix,rh_matrix
    55         real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
    56         real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
     57        real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
     58        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
     59        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: Np_matrix
     60
    5761        ! ----- OUTPUTS -----
    5862        real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
    59             g_atten_to_vol,dBZe,h_atten_to_vol   
     63            g_to_vol,dBZe,a_to_vol
    6064        ! ----- OPTIONAL -----
    61         real*8, optional, dimension(ngate,nprof) :: &
     65        real*8, optional, dimension(nprof,ngate) :: &
    6266            g_to_vol_in,g_to_vol_out
    6367     end subroutine radar_simulator
    … …  
    7377
    7478  ! Arguments
    75   type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
     79  type(cosp_gridbox),intent(inout) :: gbx  ! Gridbox info
    7680  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
    7781  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
    … …  
    8084  ! Local variables
    8185  integer :: &
    82   nsizes                        ! num of discrete drop sizes
     86  nsizes            ! num of discrete drop sizes
    8387
    84   real*8 :: &
    85   freq, &                       ! radar frequency (GHz)
    86   k2                            ! |K|^2, -1=use frequency dependent default
    87  
    8888  real*8, dimension(:,:), allocatable :: &
    8989  g_to_vol ! integrated atten due to gases, r>v (dB)
    90  
     90
    9191  real*8, dimension(:,:), allocatable :: &
    92   Ze_non, &                     ! radar reflectivity withOUT attenuation (dBZ)
    93   Ze_ray, &                     ! Rayleigh reflectivity (dBZ)
    94   h_atten_to_vol, &             ! attenuation by hydromets, radar to vol (dB)
    95   g_atten_to_vol, &             ! gaseous atteunation, radar to vol (dB)
    96   dBZe, &                       ! effective radar reflectivity factor (dBZ)
    97   hgt_matrix, &                 ! height of hydrometeors (km)
     92  Ze_non, &         ! radar reflectivity withOUT attenuation (dBZ)
     93  Ze_ray, &         ! Rayleigh reflectivity (dBZ)
     94  h_atten_to_vol, &     ! attenuation by hydromets, radar to vol (dB)
     95  g_atten_to_vol, &     ! gaseous atteunation, radar to vol (dB)
     96  dBZe, &           ! effective radar reflectivity factor (dBZ)
     97  hgt_matrix, &         ! height of hydrometeors (km)
    9898  t_matrix, &                   !temperature (k)
    9999  p_matrix, &                   !pressure (hPa)
    100100  rh_matrix                     !relative humidity (%)
    101  
     101
    102102  real*8, dimension(:,:,:), allocatable :: &
    103   hm_matrix, &                  ! hydrometeor mixing ratio (g kg^-1)
    104   re_matrix
     103  hm_matrix, &          ! hydrometeor mixing ratio (g kg^-1)
     104  re_matrix, &          ! effective radius (microns).   Optional. 0 ==> use Np_matrix or defaults
     105  Np_matrix         ! total number concentration (kg^-1).   Optional 0==> use defaults
    105106
    106107  integer, parameter :: one = 1
    107   logical :: hgt_reversed
    108   integer :: pr,i,j,k,unt
     108  ! logical :: hgt_reversed
     109  logical :: hgt_descending
     110  integer :: pr,i,j,k,unt,ngate
    109111
    110112! ----- main program settings ------
    111 
    112   freq = gbx%radar_freq
    113   k2 = gbx%k2
    114  
    115   !
    116   ! note:  intitialization section that was here has been relocated to SUBROUTINE CONSTRUCT_COSP_GRIDBOX by roj, Feb 2008
    117   !
    118   mt_ttl=gbx%mt_ttl  ! these variables really should be moved into the mt structure rather than kept as global arrays.
    119   mt_tti=gbx%mt_tti
    120113
    121114  ! Inputs to Quickbeam
    122115  allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), &
    123116           t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels))
    124   allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) 
     117  allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
    125118  allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
     119  allocate(Np_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
    126120
    127121  ! Outputs from Quickbeam
    … …  
    131125  allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels))
    132126  allocate(dBZe(gbx%Npoints,gbx%Nlevels))
    133  
     127
    134128  ! Optional argument. It is computed and returned in the first call to
    135129  ! radar_simulator, and passed as input in the rest
    136   allocate(g_to_vol(gbx%Nlevels,gbx%Npoints))
    137  
     130  allocate(g_to_vol(gbx%Npoints,gbx%Nlevels))
     131
     132  ! Even if there is no unit conversion, they are needed for type conversion
    138133  p_matrix   = gbx%p/100.0     ! From Pa to hPa
    139134  hgt_matrix = gbx%zlev/1000.0 ! From m to km
    140   t_matrix   = gbx%T-273.15    ! From K to C
     135  t_matrix   = gbx%T
    141136  rh_matrix  = gbx%q
    142137  re_matrix  = 0.0
    143  
    144   ! Quickbeam assumes the first row is closest to the radar
    145   call order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
    146       rh_matrix,gbx%surface_radar,hgt_reversed)
    147  
     138
     139
     140  ! set flag denoting position of radar relative to hgt_matrix orientation
     141          ngate = size(hgt_matrix,2)
     142
     143          hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
     144
     145          if ( &
     146             (gbx%surface_radar == 1 .and. hgt_descending) .or.  &
     147             (gbx%surface_radar == 0 .and. (.not. hgt_descending)) &
     148             ) &
     149          then
     150            gbx%hp%radar_at_layer_one = .false.
     151          else
     152            gbx%hp%radar_at_layer_one = .true.
     153          endif
     154
    148155  ! ----- loop over subcolumns -----
    149156  do pr=1,sgx%Ncolumns
     157
     158      !  NOTE:
    150159      !  atmospheric profiles are the same within the same gridbox
    151       !  only hydrometeor profiles will be different
    152       if (hgt_reversed) then 
    153          do i=1,gbx%Nhydro 
    154             hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,gbx%Nlevels:1:-1,i)*1000.0 ! Units from kg/kg to g/kg
    155             if (gbx%use_reff) then
    156               re_matrix(i,:,:) = sghydro%Reff(:,pr,gbx%Nlevels:1:-1,i)*1.e6     ! Units from m to micron
    157             endif
    158          enddo 
    159       else 
     160      !  only hydrometeor profiles will be different for each subgridbox
     161
    160162         do i=1,gbx%Nhydro
    161163            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg
    162164            if (gbx%use_reff) then
    163165              re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6       ! Units from m to micron
     166              Np_matrix(i,:,:) = sghydro%Np(:,pr,:,i)              ! Units [#/kg]
    164167            endif
    165168         enddo
    166       endif 
    167169
    168170      !   ----- call radar simulator -----
    169171      if (pr == 1) then ! Compute gaseous attenuation for all profiles
    170          j=0
    171          if (gbx%Npoints == 53) then
    172            unt=10
    173            j=1
    174          endif
    175          if (gbx%Npoints == 153) then
    176            unt=11
    177            j=101
    178          endif
    179          call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &    !  v0.2: mt changed to gbx%mt, roj
    180            gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &                         !  v0.2: hp->gbx%hp, D->gbx%d, nsizes->gbx%nsizes, roj
    181            hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, &
     172         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
     173           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
     174           p_matrix,t_matrix,rh_matrix, &
    182175           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol)
    183176      else ! Use gaseous atteunuation for pr = 1
    184          call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &
    185            gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &
    186            hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, &
     177         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
     178           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
     179           p_matrix,t_matrix,rh_matrix, &
    187180           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol)
    188181      endif
    189       ! ----- BEGIN output section -----
    190       ! spaceborne radar : from TOA to SURFACE
    191       if (gbx%surface_radar == 1) then
    192         z%Ze_tot(:,pr,:)=dBZe(:,:)
    193       else if (gbx%surface_radar == 0) then ! Spaceborne
    194         z%Ze_tot(:,pr,:)=dBZe(:,gbx%Nlevels:1:-1)
    195       endif
    196182
     183      ! store caluculated dBZe values for later output/processing
     184      z%Ze_tot(:,pr,:)=dBZe(:,:)
    197185  enddo !pr
    198  
    199   ! Change undefined value to one defined in COSP
    200   where (z%Ze_tot == -999.0) z%Ze_tot = R_UNDEF
    201186
    202187  deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix)
    … …  
    204189      Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe)
    205190  deallocate(g_to_vol)
    206  
    207   ! deallocate(mt_ttl,mt_tti)   !v0.2: roj feb 2008 can not be done here,
    208                                 !these variables now part of gbx structure and dealocated later
    209 
    210191END SUBROUTINE COSP_RADAR
    211192

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_simulator.F90

    r2298 r2435  
    11! (c) British Crown Copyright 2008, the Met Office.
    2 
    32! All rights reserved.
     3! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_simulator.F90 $
    45!
    56! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    2728! History:
    2829! Jul 2007 - A. Bodas-Salcedo - Initial version
     30! Jan 2013 - G. Cesana - Add new variables linked to the lidar cloud phase
    2931!
    30 !
    31 
     32
     33#include "cosp_defs.h"
    3234MODULE MOD_COSP_SIMULATOR
     35  USE MOD_COSP_CONSTANTS, ONLY: I_RADAR, I_LIDAR, I_ISCCP, I_MISR, I_MODIS, &
     36                                I_RTTOV, I_STATS, tsim
    3337  USE MOD_COSP_TYPES
    3438  USE MOD_COSP_RADAR
    3539  USE MOD_COSP_LIDAR
    3640  USE MOD_COSP_ISCCP_SIMULATOR
     41  USE MOD_COSP_MODIS_SIMULATOR
    3742  USE MOD_COSP_MISR_SIMULATOR
     43!#ifdef RTTOV
     44!  USE MOD_COSP_RTTOV_SIMULATOR
     45!#endif
    3846  USE MOD_COSP_STATS
    3947  IMPLICIT NONE
    … …  
    4553!--------------------- SUBROUTINE COSP_SIMULATOR ------------------
    4654!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    47 SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar)
     55!#ifdef RTTOV
     56!SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
     57!#else
     58SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     59!#endif
    4860
    4961  ! Arguments
    50   type(cosp_gridbox),intent(in) :: gbx      ! Grid-box inputs
     62  type(cosp_gridbox),intent(inout) :: gbx      ! Grid-box inputs
    5163  type(cosp_subgrid),intent(in) :: sgx      ! Subgrid inputs
    5264  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
    53   type(cosp_config),intent(in) :: cfg       ! Configuration options
     65  type(cosp_config),intent(in)  :: cfg      ! Configuration options
    5466  type(cosp_vgrid),intent(in)   :: vgrid    ! Information on vertical grid of stats
    5567  type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
    … …  
    5769  type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
    5870  type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
     71  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
     72!#ifdef RTTOV
     73!  type(cosp_rttov),intent(inout)    :: rttov    ! Output from RTTOV
     74!#endif
    5975  type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
    6076  type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
    6177  ! Local variables
    62   ! ***Timing variables (to be deleted in final version)
    63   integer :: t0,t1,count_rate,count_max
    64 
    65   !+++++++++ Radar model ++++++++++ 
     78  integer :: i,j,k,isim
     79  logical :: inconsistent
     80  ! Timing variables
     81  integer :: t0,t1
     82
     83  t0 = 0
     84  t1 = 0
     85
     86  inconsistent=.false.
     87!   do k=1,gbx%Nhydro
     88!   do j=1,gbx%Nlevels
     89!   do i=1,gbx%Npoints
     90!     if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) inconsistent=.true.
     91!   enddo
     92!   enddo
     93!   enddo
     94!  if (inconsistent)  print *, '%%%% COSP_SIMULATOR: inconsistency in mr_hydro and Reff'
     95
     96
     97  !+++++++++ Radar model ++++++++++
     98  isim = I_RADAR
    6699  if (cfg%Lradar_sim) then
     100    call system_clock(t0)
    67101    call cosp_radar(gbx,sgx,sghydro,sgradar)
    68   endif
    69  
     102    call system_clock(t1)
     103    tsim(isim) = tsim(isim) + (t1 -t0)
     104  endif
     105
    70106  !+++++++++ Lidar model ++++++++++
     107  isim = I_LIDAR
    71108  if (cfg%Llidar_sim) then
     109    call system_clock(t0)
    72110    call cosp_lidar(gbx,sgx,sghydro,sglidar)
    73   endif
    74 
    75  
     111    call system_clock(t1)
     112    tsim(isim) = tsim(isim) + (t1 -t0)
     113  endif
     114
    76115  !+++++++++ ISCCP simulator ++++++++++
     116  isim = I_ISCCP
    77117  if (cfg%Lisccp_sim) then
     118    call system_clock(t0)
    78119    call cosp_isccp_simulator(gbx,sgx,isccp)
    79   endif
    80  
     120    call system_clock(t1)
     121    tsim(isim) = tsim(isim) + (t1 -t0)
     122  endif
     123
    81124  !+++++++++ MISR simulator ++++++++++
     125  isim = I_MISR
    82126  if (cfg%Lmisr_sim) then
     127    call system_clock(t0)
    83128    call cosp_misr_simulator(gbx,sgx,misr)
    84   endif
    85  
     129    call system_clock(t1)
     130    tsim(isim) = tsim(isim) + (t1 -t0)
     131  endif
     132
     133  !+++++++++ MODIS simulator ++++++++++
     134  isim = I_MODIS
     135  if (cfg%Lmodis_sim) then
     136    call system_clock(t0)
     137    call cosp_modis_simulator(gbx,sgx,sghydro,isccp, modis)
     138    call system_clock(t1)
     139    tsim(isim) = tsim(isim) + (t1 -t0)
     140  endif
     141
     142  !+++++++++ RTTOV ++++++++++
     143  isim = I_RTTOV
     144!#ifdef RTTOV
     145!  if (cfg%Lrttov_sim) then
     146!    call system_clock(t0)
     147!    call cosp_rttov_simulator(gbx,rttov)
     148!    call system_clock(t1)
     149!    tsim(isim) = tsim(isim) + (t1 -t0)
     150!  endif
     151!#endif
    86152
    87153  !+++++++++++ Summary statistics +++++++++++
     154  isim = I_STATS
    88155  if (cfg%Lstats) then
     156    call system_clock(t0)
    89157    call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar)
    90 !    print *, '%%%%%%  Stats:', (t1-t0)*1.0/count_rate, ' s'
    91   endif
    92 
    93  
     158    call system_clock(t1)
     159    tsim(isim) = tsim(isim) + (t1 -t0)
     160  endif
     161
     162  !+++++++++++ Change of units after computation of statistics +++++++++++
     163  ! This avoids using UDUNITS in CMOR
     164
     165  ! Cloud fractions from 1 to %
     166  if (cfg%Lclcalipso) then
     167    where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0
     168  endif
     169  if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then
     170    where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0
     171  endif
     172  if (cfg%Lclcalipso2) then
     173    where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0
     174  endif
     175
     176  if (cfg%Lcltcalipsoliq.OR.cfg%Lcllcalipsoliq.OR.cfg%Lclmcalipsoliq.OR.cfg%Lclhcalipsoliq.OR. &
     177      cfg%Lcltcalipsoice.OR.cfg%Lcllcalipsoice.OR.cfg%Lclmcalipsoice.OR.cfg%Lclhcalipsoice.OR. &
     178      cfg%Lcltcalipsoun.OR.cfg%Lcllcalipsoun.OR.cfg%Lclmcalipsoun.OR.cfg%Lclhcalipsoun ) then
     179    where(stlidar%cldlayerphase /= R_UNDEF) stlidar%cldlayerphase = stlidar%cldlayerphase*100.0
     180  endif
     181  if (cfg%Lclcalipsoliq.OR.cfg%Lclcalipsoice.OR.cfg%Lclcalipsoun) then
     182    where(stlidar%lidarcldphase /= R_UNDEF) stlidar%lidarcldphase = stlidar%lidarcldphase*100.0
     183  endif
     184  if (cfg%Lclcalipsotmp.OR.cfg%Lclcalipsotmpliq.OR.cfg%Lclcalipsotmpice.OR.cfg%Lclcalipsotmpun) then
     185    where(stlidar%lidarcldtmp /= R_UNDEF) stlidar%lidarcldtmp = stlidar%lidarcldtmp*100.0
     186  endif
     187
     188  if (cfg%Lcltisccp) then
     189     where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0
     190! Test
     191!     where(isccp%totalcldarea == R_UNDEF) isccp%totalcldarea = 0.
     192  endif 
     193  if (cfg%Lclisccp) then
     194    where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0
     195  endif
     196
     197  if (cfg%LclMISR) then
     198    where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0
     199  endif
     200
     201  if (cfg%Lcltlidarradar) then
     202    where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0
     203  endif
     204
     205  if (cfg%Lclmodis) then
     206    where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = &
     207                                                      modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0
     208  endif
     209  if (cfg%Lcltmodis) then
     210     where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0
     211  endif
     212  if (cfg%Lclwmodis) then
     213     where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0
     214  endif
     215  if (cfg%Lclimodis) then
     216     where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0
     217  endif
     218
     219  if (cfg%Lclhmodis) then
     220     where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0
     221  endif
     222  if (cfg%Lclmmodis) then
     223     where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0
     224  endif
     225  if (cfg%Lcllmodis) then
     226     where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0
     227  endif
     228
     229  ! Change pressure from hPa to Pa.
     230  if (cfg%Lboxptopisccp) then
     231    where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0
     232  endif
     233  if (cfg%Lpctisccp) then
     234    where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0
     235  endif
     236
     237
    94238END SUBROUTINE COSP_SIMULATOR
    95239

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_stats.F90

    r2298 r2435  
    11! (c) British Crown Copyright 2008, the Met Office.
    22! All rights reserved.
     3! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_stats.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    3032! Oct 2008 - H. Chepfer       - Added PARASOL reflectance arguments
    3133! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations
    32 !
    33 !
     34! Jan 2013 - G. Cesana        - Added betaperp and temperature arguments
     35!                             - Added phase 3D/3Dtemperature/Map output variables in diag_lidar
     36!
     37!
     38#include "cosp_defs.h"
    3439MODULE MOD_COSP_STATS
    3540  USE MOD_COSP_CONSTANTS
    … …  
    6671   real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out
    6772   real,dimension(:,:),allocatable :: ph_c,betamol_c
     73   real,dimension(:,:,:),allocatable ::  betaperptot_out, temp_in, temp_out
     74   real,dimension(:,:),allocatable :: temp_c
    6875
    6976   Npoints  = gbx%Npoints
    … …  
    7380   Nlr      = vgrid%Nlvgrid
    7481
    75    if (cfg%Lcfad_Lidarsr532) ok_lidar_cfad=.true.
     82   if (cfg%LcfadLidarsr532) ok_lidar_cfad=.true.
    7683
    7784   if (vgrid%use_vgrid) then ! Statistics in a different vertical grid
    … …  
    8693        ph_out  = 0.0
    8794        ph_c    = 0.0
     95        allocate(betaperptot_out(Npoints,Ncolumns,Nlr),temp_in(Npoints,1,Nlevels),temp_out(Npoints,1,Nlr), &
     96                 temp_c(Npoints,Nlr))
     97        betaperptot_out = 0.0
     98        temp_in = 0.0
     99        temp_out = 0.0
     100        temp_c = 0.0
     101
    88102        !++++++++++++ Radar CFAD ++++++++++++++++
    89103        if (cfg%Lradar_sim) then
    … …  
    100114            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, &
    101115                                           Nlr,vgrid%zl,vgrid%zu,betatot_out)
     116
     117            temp_in(:,1,:) = gbx%T(:,:)
     118            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%betaperp_tot, &
     119                                           Nlr,vgrid%zl,vgrid%zu,betaperptot_out)
     120            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,temp_in, &
     121                                           Nlr,vgrid%zl,vgrid%zu,temp_out)
     122            temp_c(:,:) = temp_out(:,1,:)
     123
    102124            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, &
    103125                                           Nlr,vgrid%zl,vgrid%zu,ph_out)
    … …  
    106128            ! Stats from lidar_stat_summary
    107129            call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
    108                             ,betatot_out,betamol_c,sglidar%refl,gbx%land,ph_c &
     130                            ,temp_c,betatot_out,betaperptot_out,betamol_c,sglidar%refl,gbx%land,ph_c &
    109131                            ,LIDAR_UNDEF,ok_lidar_cfad &
    110132                            ,stlidar%cfad_sr,stlidar%srbval &
    111                             ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
     133                            ,LIDAR_NCAT,stlidar%lidarcld,stlidar%lidarcldphase &
     134                            ,stlidar%cldlayer,stlidar%cldlayerphase,stlidar%lidarcldtmp &
     135                            ,stlidar%parasolrefl)
    112136        endif
     137
    113138        !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
    114139        if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
    115                                     betatot_out,betamol_c,Ze_out, &
     140                                    temp_c,betatot_out,betaperptot_out,betamol_c,Ze_out, &
    116141                                    stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)
     142        deallocate(temp_out,temp_c,betaperptot_out)
     143
    117144        ! Deallocate arrays at coarse resolution
    118145        deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c)
    … …  
    124151        ! Stats from lidar_stat_summary
    125152        if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
    126                         ,sglidar%beta_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph &
     153                        ,sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph &
    127154                        ,LIDAR_UNDEF,ok_lidar_cfad &
    128155                        ,stlidar%cfad_sr,stlidar%srbval &
    129                         ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
     156                        ,LIDAR_NCAT,stlidar%lidarcld,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldlayerphase &
     157                        ,stlidar%lidarcldtmp,stlidar%parasolrefl)
    130158        !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
    131159        if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
    132                                     sglidar%beta_tot,sglidar%beta_mol,sgradar%Ze_tot, &
     160                                    sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sgradar%Ze_tot, &
    133161                                    stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)
    134162   endif
    … …  
    138166   where (stlidar%cldlayer  == LIDAR_UNDEF) stlidar%cldlayer  = R_UNDEF
    139167   where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF
     168   where (stlidar%cldlayerphase  == LIDAR_UNDEF) stlidar%cldlayerphase  = R_UNDEF
     169   where (stlidar%lidarcldphase  == LIDAR_UNDEF) stlidar%lidarcldphase  = R_UNDEF
     170   where (stlidar%lidarcldtmp  == LIDAR_UNDEF) stlidar%lidarcldtmp  = R_UNDEF
    140171
    141172END SUBROUTINE COSP_STATS
    142173
    143 
    144174!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    145175!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
    146176!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    147 SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,M,zl,zu,r,log_units)
     177SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units)
    148178   implicit none
    149179   ! Input arguments
    … …  
    154184   real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
    155185   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
    156    integer,intent(in) :: M  !# levels in the new grid
    157    real,dimension(M),intent(in) :: zl ! Lower boundary of new levels  [m]
    158    real,dimension(M),intent(in) :: zu ! Upper boundary of new levels  [m]
     186   integer,intent(in) :: Nglevels  !# levels in the new grid
     187   real,dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels  [m]
     188   real,dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels  [m]
    159189   logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
    160190   ! Output
    161    real,dimension(Npoints,Ncolumns,M),intent(out) :: r ! Variable on new grid
     191   real,dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid
    162192
    163193   ! Local variables
    164194   integer :: i,j,k
    165195   logical :: lunits
    166 
    167196   integer :: l
    168    real,dimension(Npoints) :: ws,sumwyp
    169    real,dimension(Npoints,Nlevels) :: xl,xu
    170    real,dimension(Npoints,Nlevels) :: w
    171    real,dimension(Npoints,Ncolumns,Nlevels) :: yp
     197   real :: w ! Weight
     198   real :: dbb, dtb, dbt, dtt ! Distances between edges of both grids
     199   integer :: Nw  ! Number of weights
     200   real :: wt  ! Sum of weights
     201   real,dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid
     202   real :: yp ! Local copy of y at a particular point.
     203              ! This allows for change of units.
    172204
    173205   lunits=.false.
    174206   if (present(log_units)) lunits=log_units
    175207
    176    r(:,:,:) = R_GROUND
    177    ! Vertical grid at that point
    178    xl(:,:) = zhalf(:,:)
    179    xu(:,1:Nlevels-1) = xl(:,2:Nlevels)
    180    xu(:,Nlevels) = zfull(:,Nlevels) +  zfull(:,Nlevels) - zhalf(:,Nlevels) ! Top level symmetric
    181    yp(:,:,:) = y(:,:,:) ! Temporary variable to regrid
    182    ! Check for dBZ and change if necessary
    183    if (lunits) then
    184      where (y /= R_UNDEF)
    185        yp = 10.0**(y/10.0)
    186      elsewhere
    187        yp = 0.0
    188      end where
    189    endif
    190    do k=1,M
    191      ! Find weights
    192      w(:,:) = 0.0
    193      do j=1,Nlevels
    194        do i=1,Npoints
    195          if ((xl(i,j) < zl(k)).and.(xu(i,j) > zl(k)).and.(xu(i,j) <= zu(k))) then
    196            !xl(j)-----------------xu(j)
    197            !      zl(k)------------------------------zu(k)
    198            w(i,j) = xu(i,j) - zl(k)
    199          else if ((xl(i,j) >= zl(k)).and.(xu(i,j) <= zu(k))) then
    200            !           xl(j)-----------------xu(j)
    201            !      zl(k)------------------------------zu(k)
    202            w(i,j) = xu(i,j) - xl(i,j)
    203          else if ((xl(i,j) >= zl(k)).and.(xl(i,j) < zu(k)).and.(xu(i,j) >= zu(k))) then
    204            !                           xl(j)-----------------xu(j)
    205            !      zl(k)------------------------------zu(k)
    206            w(i,j) = zu(k) - xl(i,j)
    207          else if ((xl(i,j) <= zl(k)).and.(xu(i,j) >= zu(k))) then
    208            !  xl(j)---------------------------xu(j)
    209            !        zl(k)--------------zu(k)
    210            w(i,j) = zu(k) - zl(k)
     208   r = 0.0
     209
     210   do i=1,Npoints
     211     ! Calculate tops and bottoms of new and old grids
     212     oldgrid_bot = zhalf(i,:)
     213     oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels)
     214     oldgrid_top(Nlevels) = zfull(i,Nlevels) +  zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric
     215     l = 0 ! Index of level in the old grid
     216     ! Loop over levels in the new grid
     217     do k = 1,Nglevels
     218       Nw = 0 ! Number of weigths
     219       wt = 0.0 ! Sum of weights
     220       ! Loop over levels in the old grid and accumulate total for weighted average
     221       do
     222         l = l + 1
     223         w = 0.0 ! Initialise weight to 0
     224         ! Distances between edges of both grids
     225         dbb = oldgrid_bot(l) - newgrid_bot(k)
     226         dtb = oldgrid_top(l) - newgrid_bot(k)
     227         dbt = oldgrid_bot(l) - newgrid_top(k)
     228         dtt = oldgrid_top(l) - newgrid_top(k)
     229         if (dbt >= 0.0) exit ! Do next level in the new grid
     230         if (dtb > 0.0) then
     231           if (dbb <= 0.0) then
     232             if (dtt <= 0) then
     233               w = dtb
     234             else
     235               w = newgrid_top(k) - newgrid_bot(k)
     236             endif
     237           else
     238             if (dtt <= 0) then
     239               w = oldgrid_top(l) - oldgrid_bot(l)
     240             else
     241               w = -dbt
     242             endif
     243           endif
     244           ! If layers overlap (w/=0), then accumulate
     245           if (w /= 0.0) then
     246             Nw = Nw + 1
     247             wt = wt + w
     248             do j=1,Ncolumns
     249               if (lunits) then
     250                 if (y(i,j,l) /= R_UNDEF) then
     251                   yp = 10.0**(y(i,j,l)/10.0)
     252                 else
     253                   yp = 0.0
     254                 endif
     255               else
     256                 yp = y(i,j,l)
     257               endif
     258               r(i,j,k) = r(i,j,k) + w*yp
     259             enddo
     260           endif
    211261         endif
    212262       enddo
     263       l = l - 2
     264       if (l < 1) l = 0
     265       ! Calculate average in new grid
     266       if (Nw > 0) then
     267         do j=1,Ncolumns
     268           r(i,j,k) = r(i,j,k)/wt
     269         enddo
     270       endif
    213271     enddo
    214      ! Do the weighted mean
     272   enddo
     273
     274   ! Set points under surface to R_UNDEF, and change to dBZ if necessary
     275   do k=1,Nglevels
    215276     do j=1,Ncolumns
    216        ws    (:) = 0.0
    217        sumwyp(:) = 0.0
    218        do l=1,Nlevels
    219          do i=1,Npoints
    220            if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
    221              ws    (i) = ws    (i) + w(i,l)
    222              sumwyp(i) = sumwyp(i) + w(i,l)*yp(i,j,l)
     277       do i=1,Npoints
     278         if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level
     279           if (lunits) then
     280             if (r(i,j,k) <= 0.0) then
     281               r(i,j,k) = R_UNDEF
     282             else
     283               r(i,j,k) = 10.0*log10(r(i,j,k))
     284             endif
    223285           endif
    224          enddo
    225        enddo
    226        do i=1,Npoints
    227          if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
    228            if (ws(i) > 0.0) r(i,j,k) = sumwyp(i)/ws(i)
     286         else ! Level below surface
     287           r(i,j,k) = R_GROUND
    229288         endif
    230289       enddo
    231290     enddo
    232291   enddo
    233    ! Check for dBZ and change if necessary
    234    if (lunits) then
    235      do k=1,M
    236        do j=1,Ncolumns
    237          do i=1,Npoints
    238            if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
    239              if (r(i,j,k) <= 0.0) then
    240                  r(i,j,k) = R_UNDEF
    241              else
    242                  r(i,j,k) = 10.0*log10(r(i,j,k))
    243              endif
    244            endif
    245          enddo
    246        enddo
    247      enddo
    248    endif
    249 
    250 
    251292
    252293END SUBROUTINE COSP_CHANGE_VERTICAL_GRID

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_types.F90

    r2298 r2435  
    2323! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    2424
    25 !
    26 ! History:
    27 ! Jul 2007 - A. Bodas-Salcedo - Initial version
    28 ! Feb 2008 - R. Marchand      - Added Quickbeam types and initialisation
    29 ! Oct 2008 - H. Chepfer       - Added PARASOL reflectance diagnostic
    30 ! Nov 2008 - R. Marchand      - Added MISR diagnostics
    31 ! Nov 2008 - V. John          - Added RTTOV diagnostics
    32 !
    33 !
    3425MODULE MOD_COSP_TYPES
    3526    USE MOD_COSP_CONSTANTS
    3627    USE MOD_COSP_UTILS
    3728
    38     use radar_simulator_types, only: class_param, mie, nd, mt_nd, dmax, dmin, mt_ttl, mt_tti, cnt_liq, cnt_ice  ! added by roj Feb 2008
     29    use radar_simulator_types, only: class_param, nd, mt_nd, dmax, dmin
    3930
    4031    IMPLICIT NONE
    41    
     32
    4233!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    4334!----------------------- DERIVED TYPES ----------------------------   
    … …  
    4637  ! Configuration choices (simulators, variables)
    4738  TYPE COSP_CONFIG
    48      logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
    49                 Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
    50                 Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
    51                 Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
    52                 Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
    53                 Lfrac_out,Lbeta_mol532,Ltbrttov
     39     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
     40                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
     41                LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
     42                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
     43                Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
     44                Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
     45                Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
     46                      Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
     47                Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
     48                Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
     49                Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
     50                Lfracout,LlidarBetaMol532,Ltbrttov, &
     51                Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
     52                Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
     53                Liwpmodis,Lclmodis
     54
    5455     character(len=32) :: out_list(N_OUT_LIST)
    5556  END TYPE COSP_CONFIG
    … …  
    145146    ! Arrays with dimensions (Npoints,Nlevels)
    146147    real,dimension(:,:),pointer :: beta_mol   ! Molecular backscatter
     148    real,dimension(:,:),pointer :: temp_tot
    147149    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
     150    real,dimension(:,:,:),pointer :: betaperp_tot   ! Total backscattered signal
    148151    real,dimension(:,:,:),pointer :: beta_tot   ! Total backscattered signal
    149152    real,dimension(:,:,:),pointer :: tau_tot    ! Optical thickness integrated from top to level z
    … …  
    197200    real, dimension(:,:),pointer :: lidarcld    ! 3D "lidar" cloud fraction
    198201    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
    199     real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level lidar cloud cover
     202    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level, total lidar cloud cover
     203   ! Arrays with dimensions (Npoints,Nlevels,Nphase)
     204    real, dimension(:,:,:),pointer :: lidarcldphase    ! 3D "lidar" phase cloud fraction
     205     ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
     206    real, dimension(:,:,:),pointer :: cldlayerphase      ! low, mid, high-level lidar phase cloud cover
     207    ! Arrays with dimensions (Npoints,Ntemps,Nphase)
     208    real, dimension(:,:,:),pointer :: lidarcldtmp    ! 3D "lidar" phase cloud temperature
    200209    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
    201210    real, dimension(:,:),pointer :: parasolrefl   ! mean parasol reflectance
    … …  
    230239                                                ! (Reff==0 means use default size)   
    231240                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [m]
     241    real,dimension(:,:,:,:),pointer :: Np       ! Total # concentration each hydrometeor
     242                                                ! (Optional, ignored if Reff > 0).
     243                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [#/kg]
     244                                                ! Np = Ntot / rho_a  = [#/m^3] / [kg/m^3)
     245                                                ! added by Roj with Quickbeam V3
    232246  END TYPE COSP_SGHYDRO
    233247 
    … …  
    246260    ! Time [days]
    247261    double precision :: time
     262    double precision :: time_bnds(2)
    248263   
    249264    ! Radar ancillary info
    … …  
    251266            k2 ! |K|^2, -1=use frequency dependent default
    252267    integer :: surface_radar, & ! surface=1, spaceborne=0
    253                use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
    254                use_gas_abs, & ! include gaseous absorption? yes=1,no=0
    255                do_ray, & ! calculate/output Rayleigh refl=1, not=0
    256                melt_lay ! melting layer model off=0, on=1
     268           use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
     269           use_gas_abs, & ! include gaseous absorption? yes=1,no=0
     270           do_ray, & ! calculate/output Rayleigh refl=1, not=0
     271           melt_lay ! melting layer model off=0, on=1
    257272 
    258273    ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008
    259     type(class_param) ::  hp    ! structure used by radar simulator to store Ze and N scaling constants and other information
    260     type(mie)::  mt             ! structure used by radar simulator to store mie LUT information
    261     integer :: nsizes           ! number of discrete drop sizes (um) used to represent the distribution
    262     real*8, dimension(:), pointer :: D ! array of discrete drop sizes (um) used to represent the distribution
    263     real*8, dimension(:), pointer :: mt_ttl, mt_tti ! array of temperatures used with Ze_scaling (also build into mie LUT)
     274    type(class_param) ::  hp    ! structure used by radar simulator to store Ze and N scaling constants and other information
     275    integer :: nsizes       ! number of discrete drop sizes (um) used to represent the distribution
    264276   
    265277    ! Lidar
    … …  
    269281    ! Radar
    270282    logical ::  use_precipitation_fluxes  ! True if precipitation fluxes are input to the algorithm
    271     logical ::  use_reff  ! True if Reff is to be used by radar
     283    logical ::  use_reff          ! True if Reff is to be used by radar (memory not allocated
     284   
    272285   
    273286    ! Geolocation (Npoints)
     287    real,dimension(:),pointer :: toffset   ! Time offset of esch point from the value in time
    274288    real,dimension(:),pointer :: longitude ! longitude [degrees East]
    275289    real,dimension(:),pointer :: latitude  ! latitude [deg North]
    … …  
    302316    real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime
    303317    real,dimension(:),pointer :: skt  ! Skin temperature (K)
    304     real,dimension(:),pointer :: sfc_height  ! Surface height [m]
    305318    real,dimension(:),pointer :: u_wind  ! eastward wind [m s-1]
    306319    real,dimension(:),pointer :: v_wind  ! northward wind [m s-1]
    … …  
    319332    real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg]
    320333    real,dimension(:,:),pointer   :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro)
    321     ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
     334
     335    ! Effective radius [m]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
    322336    real,dimension(:,:,:),pointer :: Reff
     337
     338    ! Total Number Concentration [#/kg]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
     339    real,dimension(:,:,:),pointer :: Np ! added by Roj with Quickbeam V3
     340 
    323341    ! Aerosols concentration and distribution parameters
    324342    real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero)
    … …  
    373391!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV -------------------
    374392!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    375   SUBROUTINE CONSTRUCT_COSP_RTTOV(Npoints,Nchan,x)
     393  SUBROUTINE CONSTRUCT_COSP_RTTOV(cfg,Npoints,Nchan,x)
     394    type(cosp_config),intent(in) :: cfg ! Configuration options
    376395    integer,intent(in) :: Npoints  ! Number of sampled points
    377396    integer,intent(in) :: Nchan ! Number of channels
    378397    type(cosp_rttov),intent(out) :: x
    379    
    380     ! Dimensions
    381     x%Npoints  = Npoints
    382     x%Nchan    = Nchan
     398    ! Local variables
     399    integer :: i,j
     400   
     401    ! Allocate minumum storage if simulator not used
     402    if (cfg%Lrttov_sim) then
     403      i = Npoints
     404      j = Nchan
     405    else
     406      i = 1
     407      j = 1
     408    endif
     409    x%Npoints  = i
     410    x%Nchan    = j
    383411     
    384412    ! --- Allocate arrays ---
    385     allocate(x%tbs(Npoints, Nchan))
     413    allocate(x%tbs(i, j))
    386414    ! --- Initialise to zero ---
    387415    x%tbs     = 0.0
    … …  
    608636    ! --- Allocate arrays ---
    609637    allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), &
    610              x%tau_tot(i,j,k),x%refl(i,j,m))
     638             x%tau_tot(i,j,k),x%refl(i,j,m), &
     639             x%temp_tot(i,k),x%betaperp_tot(i,j,k))
    611640    ! --- Initialise to zero ---
    612641    x%beta_mol   = 0.0
    … …  
    614643    x%tau_tot    = 0.0
    615644    x%refl       = 0.0 ! parasol
     645    x%temp_tot          = 0.0
     646    x%betaperp_tot      = 0.0   
    616647  END SUBROUTINE CONSTRUCT_COSP_SGLIDAR
    617648
    … …  
    622653    type(cosp_sglidar),intent(inout) :: x
    623654
    624     deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl)
     655    deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl, &
     656               x%temp_tot, x%betaperp_tot)
     657
    625658  END SUBROUTINE FREE_COSP_SGLIDAR
    626659
    … …  
    766799   
    767800    ! --- Allocate arrays ---
    768     allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), & 
     801    allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), &
    769802             x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m))
     803    allocate(x%lidarcldphase(i,k,6),x%lidarcldtmp(i,LIDAR_NTEMP,5),&
     804             x%cldlayerphase(i,LIDAR_NCAT,6))
    770805    ! --- Initialise to zero ---
    771806    x%srbval    = 0.0
    … …  
    774809    x%cldlayer  = 0.0
    775810    x%parasolrefl  = 0.0
    776   END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS
     811    x%lidarcldphase  = 0.0
     812    x%cldlayerphase  = 0.0
     813    x%lidarcldtmp  = 0.0
     814
     815   END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS
    777816
    778817!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    … …  
    783822
    784823    deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl)
     824    deallocate(x%cldlayerphase, x%lidarcldtmp, x%lidarcldphase)
    785825  END SUBROUTINE FREE_COSP_LIDARSTATS
    786  
     826
    787827
    788828!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    … …  
    849889    ! --- Allocate arrays ---
    850890    allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), &
    851              y%Reff(Npoints,Ncolumns,Nlevels,Nhydro))
     891             y%Reff(Npoints,Ncolumns,Nlevels,Nhydro), &
     892             y%Np(Npoints,Ncolumns,Nlevels,Nhydro)) ! added by roj with Quickbeam V3
     893             
    852894    ! --- Initialise to zero ---
    853895    y%mr_hydro = 0.0
    854896    y%Reff     = 0.0
     897    y%Np       = 0.0                    ! added by roj with Quickbeam V3
    855898
    856899  END SUBROUTINE CONSTRUCT_COSP_SGHYDRO
    … …  
    863906   
    864907    ! --- Deallocate arrays ---
    865     deallocate(y%mr_hydro, y%Reff)
     908    deallocate(y%mr_hydro, y%Reff, y%Np)        ! added by Roj with Quickbeam V3
    866909       
    867910  END SUBROUTINE FREE_COSP_SGHYDRO
    … …  
    870913!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------
    871914!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    872   SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
    873                                    Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & 
     915  SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
     916                                   Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
    874917                                   lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, &
    875918                                   use_precipitation_fluxes,use_reff, &
    876919                                   ! RTTOV inputs
    877920                                   Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,&
    878                                    y)
     921                                   y,load_LUT)
    879922    double precision,intent(in) :: time ! Time since start of run [days]
     923    double precision,intent(in) :: time_bnds(2) ! Time boundaries
    880924    real,intent(in)    :: radar_freq, & ! Radar frequency [GHz]
    881925                          k2            ! |K|^2, -1=use frequency dependent default
    … …  
    909953    real,intent(in)    :: co2,ch4,n2o,co
    910954    type(cosp_gridbox),intent(out) :: y
    911 
    912        
     955    logical,intent(in),optional :: load_LUT
     956
     957
    913958    ! local variables
    914     integer i, cnt_ice, cnt_liq
    915     character*200 :: mie_table_name ! Mie table name 
    916     real*8  :: delt, deltp
    917  
     959    character*240 :: LUT_file_name
     960    logical :: local_load_LUT
     961
     962    if (present(load_LUT)) then
     963      local_load_LUT = load_LUT
     964    else
     965      local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag
     966    endif
     967
    918968    ! Dimensions and scalars
    919969    y%radar_freq       = radar_freq
    … …  
    940990    y%use_reff = use_reff
    941991   
    942     y%time = time
     992    y%time      = time
     993    y%time_bnds = time_bnds
    943994   
    944995    ! RTTOV parameters
    … …  
    9661017             
    9671018    ! Surface information and geolocation (Npoints)
    968     allocate(y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
    969              y%sunlit(Npoints),y%skt(Npoints),y%sfc_height(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
     1019    allocate(y%toffset(Npoints), y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
     1020             y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
    9701021    ! Hydrometeors concentration and distribution parameters
    9711022    allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), &
    9721023             y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), &
    973              y%Reff(Npoints,Nlevels,Nhydro))
     1024             y%Reff(Npoints,Nlevels,Nhydro), &
     1025             y%Np(Npoints,Nlevels,Nhydro))      ! added by Roj with Quickbeam V3
    9741026    ! Aerosols concentration and distribution parameters
    9751027    allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), &
    … …  
    10041056    y%snow_cv   = 0.0
    10051057    y%Reff      = 0.0
     1058    y%Np        = 0.0 ! added by Roj with Quickbeam V3
    10061059    y%mr_ozone  = 0.0
    10071060    y%u_wind    = 0.0
    … …  
    10101063   
    10111064    ! (Npoints)
    1012 !     call zero_real(y%psfc, y%land)
     1065    y%toffset = 0.0
    10131066    y%longitude = 0.0
    10141067    y%latitude = 0.0
    … …  
    10171070    y%sunlit = 0.0
    10181071    y%skt = 0.0
    1019     y%sfc_height = 0.0
    10201072    ! (Npoints,Nlevels,Nhydro)
    10211073!     y%fr_hydro = 0.0
    … …  
    10271079    y%dist_prmts_aero  = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
    10281080
    1029     y%hp%p1 = 0.0
    1030     y%hp%p2 = 0.0
    1031     y%hp%p3 = 0.0
    1032     y%hp%dmin = 0.0
    1033     y%hp%dmax = 0.0
    1034     y%hp%apm = 0.0
    1035     y%hp%bpm = 0.0
    1036     y%hp%rho = 0.0
    1037     y%hp%dtype = 0
    1038     y%hp%col = 0
    1039     y%hp%cp = 0
    1040     y%hp%phase = 0
    1041     y%hp%scaled = .false.
    1042     y%hp%z_flag = .false.
    1043     y%hp%Ze_scaled = 0.0
    1044     y%hp%Zr_scaled = 0.0
    1045     y%hp%kr_scaled = 0.0
    1046     y%hp%fc = 0.0
    1047     y%hp%rho_eff = 0.0
    1048     y%hp%ifc = 0
    1049     y%hp%idd = 0
    1050     y%mt%freq = 0.0
    1051     y%mt%tt = 0.0
    1052     y%mt%f = 0.0
    1053     y%mt%D = 0.0
    1054     y%mt%qext = 0.0
    1055     y%mt%qbsca = 0.0
    1056     y%mt%phase = 0
    1057    
    1058    
    1059     ! --- Initialize the distributional parameters for hydrometeors
    1060     y%dist_prmts_hydro( 1,:) = HCLASS_TYPE(:)
    1061     y%dist_prmts_hydro( 2,:) = HCLASS_COL(:)
    1062     y%dist_prmts_hydro( 3,:) = HCLASS_PHASE(:)
    1063     y%dist_prmts_hydro( 4,:) = HCLASS_CP(:)
    1064     y%dist_prmts_hydro( 5,:) = HCLASS_DMIN(:)
    1065     y%dist_prmts_hydro( 6,:) = HCLASS_DMAX(:)
    1066     y%dist_prmts_hydro( 7,:) = HCLASS_APM(:)
    1067     y%dist_prmts_hydro( 8,:) = HCLASS_BPM(:)
    1068     y%dist_prmts_hydro( 9,:) = HCLASS_RHO(:)
    1069     y%dist_prmts_hydro(10,:) = HCLASS_P1(:)
    1070     y%dist_prmts_hydro(11,:) = HCLASS_P2(:)
    1071     y%dist_prmts_hydro(12,:) = HCLASS_P3(:)
    1072 
    1073     ! the following code added by roj to initialize structures used by radar simulator, Feb 2008
    1074     call load_hydrometeor_classes(y%Nprmts_max_hydro,y%dist_prmts_hydro(:,:),y%hp,y%Nhydro)
    1075 
    1076     ! load mie tables ?
    1077     if (y%use_mie_tables == 1) then
    1078 
    1079         ! ----- Mie tables ----
    1080             mie_table_name='mie_table.dat'
    1081         call load_mie_table(mie_table_name,y%mt)
    1082        
    1083             !   :: D specified by table ... not must match that used when mie LUT generated!
    1084         y%nsizes = mt_nd
    1085         allocate(y%D(y%nsizes))
    1086         y%D = y%mt%D
    1087 
    1088     else
    1089            ! otherwise we still need to initialize temperature arrays for Ze scaling (which is only done when not using mie table)
    1090            
    1091            cnt_ice=19
    1092            cnt_liq=20
    1093        if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then
    1094           allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))  ! note needed as this is global array ...
    1095                                                      ! which should be changed in the future
    1096        endif
    1097                  
    1098            do i=1,cnt_ice
    1099                   mt_tti(i)=(i-1)*5-90
    1100            enddo
    1101    
    1102            do i=1,cnt_liq
    1103                   mt_ttl(i)=(i-1)*5 - 60
    1104            enddo
    1105    
    1106            allocate(y%mt_ttl(cnt_liq),y%mt_tti(cnt_ice))
    1107 
    1108        y%mt_ttl = mt_ttl
    1109        y%mt_tti = mt_tti
    1110 
    1111 ! !------ OLD code in v0.1 ---------------------------
    1112 !        allocate(mt_ttl(2),mt_tti(2))
    1113 !        allocate(y%mt_ttl(2),y%mt_tti(2))
    1114 !        mt_ttl = 0.0
    1115 !        mt_tti = 0.0
    1116 !        y%mt_ttl = mt_ttl
    1117 !        y%mt_tti = mt_tti
    1118 ! !---------------------------------------------------
    1119        
    1120        ! :: D created on a log-linear scale
    1121        y%nsizes = nd
    1122        delt = (log(dmax)-log(dmin))/(y%nsizes-1)
    1123        deltp = exp(delt)
    1124        allocate(y%D(y%nsizes))
    1125        y%D(1) = dmin
    1126        do i=2,y%nsizes
    1127           y%D(i) = y%D(i-1)*deltp
    1128        enddo   
    1129    
     1081
     1082    ! NOTE: This location use to contain initialization of some radar simulator variables
     1083    ! this initialization (including use of the variable "dist_prmts_hydro" - now obselete)
     1084    ! has been unified in the quickbeam v3 subroutine "radar_simulator_init".   Roj, June 2010
     1085
     1086    ! --- Initialize the distributional parameters for hydrometeors in radar simulator
     1087
     1088    write(*,*) 'RADAR_SIM microphysics scheme is set to: ', &
     1089            trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
     1090
     1091
     1092    if(y%Nhydro.ne.N_HYDRO) then
     1093
     1094        write(*,*) 'Number of hydrometeor input to subroutine', &
     1095               ' CONSTRUCT_COSP_GRIDBOX does not match value', &
     1096               ' specified in cosp_constants.f90!'
     1097        write(*,*)
    11301098    endif
    11311099
     1100    ! NOTE: SAVE_scale_LUTs_flag is hard codded as .false. here
     1101    ! so that radar simulator will NOT update LUT each time it
     1102    ! is called, but rather will update when "Free_COSP_GRIDBOX" is called!
     1103    ! Roj, June 2010
     1104
     1105    LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // &
     1106                trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
     1107
     1108    call radar_simulator_init(radar_freq,k2, &
     1109                      use_gas_abs,do_ray,R_UNDEF, &
     1110                      y%Nhydro, &
     1111                      HCLASS_TYPE,HCLASS_PHASE, &
     1112                      HCLASS_DMIN,HCLASS_DMAX, &
     1113                      HCLASS_APM,HCLASS_BPM,HCLASS_RHO, &
     1114                      HCLASS_P1,HCLASS_P2,HCLASS_P3, &
     1115                      local_load_LUT,    &
     1116                      .false., &
     1117                      LUT_file_name, &
     1118                      y%hp)
    11321119
    11331120END SUBROUTINE CONSTRUCT_COSP_GRIDBOX
    11341121
    1135  
     1122
    11361123!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    11371124!------------- SUBROUTINE FREE_COSP_GRIDBOX -----------------------
    11381125!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    1139   SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal)
     1126  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal,save_LUT)
     1127
     1128    use scale_LUTs_io
     1129
    11401130    type(cosp_gridbox),intent(inout) :: y
    11411131    logical,intent(in),optional :: dglobal
    1142 
    1143     ! --- Free arrays ---
    1144     deallocate(y%D,y%mt_ttl,y%mt_tti)   ! added by roj Feb 2008
    1145     if (.not.present(dglobal)) deallocate(mt_ttl,mt_tti)
    1146    
    1147 !     deallocate(y%hp%p1,y%hp%p2,y%hp%p3,y%hp%dmin,y%hp%dmax,y%hp%apm,y%hp%bpm,y%hp%rho, &
    1148 !               y%hp%dtype,y%hp%col,y%hp%cp,y%hp%phase,y%hp%scaled, &
    1149 !               y%hp%z_flag,y%hp%Ze_scaled,y%hp%Zr_scaled,y%hp%kr_scaled, &
    1150 !               y%hp%fc, y%hp%rho_eff, y%hp%ifc, y%hp%idd)
    1151 !     deallocate(y%mt%freq, y%mt%tt, y%mt%f, y%mt%D, y%mt%qext, y%mt%qbsca, y%mt%phase)
    1152    
     1132    logical,intent(in),optional :: save_LUT
     1133
     1134    logical :: local_save_LUT
     1135
     1136    if (present(save_LUT)) then
     1137      local_save_LUT = save_LUT
     1138    else
     1139      local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag
     1140    endif
     1141
     1142    ! save any updates to radar simulator LUT
     1143    if (local_save_LUT) call save_scale_LUTs(y%hp)
     1144
    11531145    deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, &
    11541146               y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, &
    1155                y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
     1147               y%toffset, y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
    11561148               y%mr_hydro, y%dist_prmts_hydro, &
    11571149               y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, &
    11581150               y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, &
    1159                y%sunlit, y%skt, y%sfc_height, y%Reff,y%ichan,y%surfem, &
     1151               y%sunlit, y%skt, y%Reff,y%Np, &
     1152               y%ichan,y%surfem, &
    11601153               y%mr_ozone,y%u_wind,y%v_wind)
    1161  
     1154
    11621155  END SUBROUTINE FREE_COSP_GRIDBOX
    1163  
    11641156
    11651157!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    … …  
    11691161    type(cosp_gridbox),intent(in) :: x
    11701162    type(cosp_gridbox),intent(inout) :: y
    1171    
     1163
    11721164    integer :: i,j,k,sz(3)
    11731165    double precision :: tny
    1174    
     1166
    11751167    tny = tiny(tny)
    11761168    y%hp%p1      = x%hp%p1
    … …  
    11891181    y%hp%fc      = x%hp%fc
    11901182    y%hp%rho_eff = x%hp%rho_eff
    1191     y%hp%ifc     = x%hp%ifc
    1192     y%hp%idd     = x%hp%idd
    1193     sz = shape(x%hp%z_flag)
     1183    ! y%hp%ifc     = x%hp%ifc       obsolete, Roj, June 2010
     1184    ! y%hp%idd     = x%hp%idd
     1185    sz = shape(x%hp%Z_scale_flag)
    11941186    do k=1,sz(3)
    11951187      do j=1,sz(2)
    11961188        do i=1,sz(1)
    1197            if (x%hp%scaled(i,k))   y%hp%scaled(i,k)      = .true.
    1198            if (x%hp%z_flag(i,j,k)) y%hp%z_flag(i,j,k)    = .true.
     1189           if (x%hp%N_scale_flag(i,k))   y%hp%N_scale_flag(i,k)      = .true.
     1190           if (x%hp%Z_scale_flag(i,j,k)) y%hp%Z_scale_flag(i,j,k)    = .true.
    11991191           if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k)
    12001192           if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k)
    … …  
    12141206    type(cosp_gridbox),intent(inout) :: y
    12151207   
    1216     integer :: i,j,k,sz(3)
    1217    
    12181208    ! --- Copy arrays without Npoints as dimension ---
    12191209    y%dist_prmts_hydro = x%dist_prmts_hydro
    12201210    y%dist_type_aero   = x%dist_type_aero
    1221     y%D                = x%D
    1222     y%mt_ttl           = x%mt_ttl
    1223     y%mt_tti           = x%mt_tti
    1224    
     1211 
    12251212   
    12261213!     call cosp_gridbox_cphp(x,y)   
    … …  
    12331220    y%sunlit(iy(1):iy(2))     = x%sunlit(ix(1):ix(2))
    12341221    y%skt(iy(1):iy(2))        = x%skt(ix(1):ix(2))
    1235     y%sfc_height(iy(1):iy(2)) = x%sfc_height(ix(1):ix(2))
    12361222    y%u_wind(iy(1):iy(2))     = x%u_wind(ix(1):ix(2))
    12371223    y%v_wind(iy(1):iy(2))     = x%v_wind(ix(1):ix(2))
    … …  
    12591245    ! 3D
    12601246    y%Reff(iy(1):iy(2),:,:)      = x%Reff(ix(1):ix(2),:,:)
     1247    y%Np(iy(1):iy(2),:,:)      = x%Np(ix(1):ix(2),:,:)   ! added by Roj with Quickbeam V3
    12611248    y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:)
    12621249    y%mr_hydro(iy(1):iy(2),:,:)  = x%mr_hydro(ix(1):ix(2),:,:)
    … …  
    12971284    type(cosp_sglidar),intent(in) :: x
    12981285    type(cosp_sglidar),intent(inout) :: y
    1299    
     1286
     1287    y%temp_tot(iy(1):iy(2),:)       = x%temp_tot(ix(1):ix(2),:)
     1288    y%betaperp_tot(iy(1):iy(2),:,:) = x%betaperp_tot(ix(1):ix(2),:,:)
    13001289    y%beta_mol(iy(1):iy(2),:)       = x%beta_mol(ix(1):ix(2),:)
    13011290    y%beta_tot(iy(1):iy(2),:,:)     = x%beta_tot(ix(1):ix(2),:,:)
    … …  
    13111300    type(cosp_isccp),intent(in) :: x
    13121301    type(cosp_isccp),intent(inout) :: y
    1313            
     1302
    13141303    y%fq_isccp(iy(1):iy(2),:,:)  = x%fq_isccp(ix(1):ix(2),:,:)
    13151304    y%totalcldarea(iy(1):iy(2))  = x%totalcldarea(ix(1):ix(2))
    … …  
    13751364    y%cldlayer(iy(1):iy(2),:)    = x%cldlayer(ix(1):ix(2),:)
    13761365    y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:)
     1366    y%lidarcldphase(iy(1):iy(2),:,:)  = x%lidarcldphase(ix(1):ix(2),:,:)
     1367    y%cldlayerphase(iy(1):iy(2),:,:)  = x%cldlayerphase(ix(1):ix(2),:,:)
     1368    y%lidarcldtmp(iy(1):iy(2),:,:)    = x%lidarcldtmp(ix(1):ix(2),:,:)
    13771369END SUBROUTINE COSP_LIDARSTATS_CPSECTION
     1370!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     1371!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     1372!------------- PRINT SUBROUTINES --------------
     1373!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     1374!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     1375SUBROUTINE COSP_GRIDBOX_PRINT(x)
     1376    type(cosp_gridbox),intent(in) :: x
     1377
     1378    print *, '%%%%----- Information on COSP_GRIDBOX ------'
     1379    ! Scalars and dimensions
     1380    print *,  x%Npoints
     1381    print *,  x%Nlevels
     1382    print *,  x%Ncolumns
     1383    print *,  x%Nhydro
     1384    print *,  x%Nprmts_max_hydro
     1385    print *,  x%Naero
     1386    print *,  x%Nprmts_max_aero
     1387    print *,  x%Npoints_it
     1388   
     1389    ! Time [days]
     1390    print *,  x%time
     1391   
     1392    ! Radar ancillary info
     1393    print *,  x%radar_freq, &
     1394            x%k2
     1395    print *,  x%surface_radar, &
     1396              x%use_mie_tables, &
     1397              x%use_gas_abs, &
     1398              x%do_ray, &
     1399              x%melt_lay
     1400
     1401!               print *,  'shape(x%): ',shape(x%)
     1402 
     1403!     type(class_param) ::  hp  ! structure used by radar simulator to store Ze and N scaling constants and other information
     1404!     type(mie)::  mt           ! structure used by radar simulator to store mie LUT information
     1405    print *,  x%nsizes
     1406   
     1407    ! Lidar
     1408    print *,  x%lidar_ice_type
     1409   
     1410    ! Radar
     1411    print *,  x%use_precipitation_fluxes
     1412    print *,  x%use_reff
     1413   
     1414    ! Geolocation (Npoints)
     1415    print *,  'shape(x%longitude): ',shape(x%longitude)
     1416    print *,  'shape(x%latitude): ',shape(x%latitude)
     1417    ! Gridbox information (Npoints,Nlevels)
     1418    print *,  'shape(x%zlev): ',shape(x%zlev)
     1419    print *,  'shape(x%zlev_half): ',shape(x%zlev_half)
     1420    print *,  'shape(x%dlev): ',shape(x%dlev)
     1421    print *,  'shape(x%p): ',shape(x%p)
     1422    print *,  'shape(x%ph): ',shape(x%ph)
     1423    print *,  'shape(x%T): ',shape(x%T)
     1424    print *,  'shape(x%q): ',shape(x%q)
     1425    print *,  'shape(x%sh): ',shape(x%sh)
     1426    print *,  'shape(x%dtau_s): ',shape(x%dtau_s)
     1427    print *,  'shape(x%dtau_c): ',shape(x%dtau_c)
     1428    print *,  'shape(x%dem_s): ',shape(x%dem_s)
     1429    print *,  'shape(x%dem_c): ',shape(x%dem_c)
     1430    print *,  'shape(x%mr_ozone): ',shape(x%mr_ozone)
     1431
     1432    ! Point information (Npoints)
     1433    print *,  'shape(x%land): ',shape(x%land)
     1434    print *,  'shape(x%psfc): ',shape(x%psfc)
     1435    print *,  'shape(x%sunlit): ',shape(x%sunlit)
     1436    print *,  'shape(x%skt): ',shape(x%skt)
     1437    print *,  'shape(x%u_wind): ',shape(x%u_wind)
     1438    print *,  'shape(x%v_wind): ',shape(x%v_wind)
     1439
     1440    ! TOTAL and CONV cloud fraction for SCOPS
     1441    print *,  'shape(x%tca): ',shape(x%tca)
     1442    print *,  'shape(x%cca): ',shape(x%cca)
     1443    ! Precipitation fluxes on model levels
     1444    print *,  'shape(x%rain_ls): ',shape(x%rain_ls)
     1445    print *,  'shape(x%rain_cv): ',shape(x%rain_cv)
     1446    print *,  'shape(x%snow_ls): ',shape(x%snow_ls)
     1447    print *,  'shape(x%snow_cv): ',shape(x%snow_cv)
     1448    print *,  'shape(x%grpl_ls): ',shape(x%grpl_ls)
     1449    ! Hydrometeors concentration and distribution parameters
     1450    print *,  'shape(x%mr_hydro): ',shape(x%mr_hydro)
     1451    print *,  'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro)
     1452    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
     1453    print *,  'shape(x%Reff): ',shape(x%Reff)
     1454    print *,  'shape(x%Np): ',shape(x%Np)       ! added by roj with Quickbeam V3
     1455    ! Aerosols concentration and distribution parameters
     1456    print *,  'shape(x%conc_aero): ',shape(x%conc_aero)
     1457    print *,  'shape(x%dist_type_aero): ',shape(x%dist_type_aero)
     1458    print *,  'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero)
     1459    ! ISCCP simulator inputs
     1460    print *, x%isccp_top_height
     1461    print *, x%isccp_top_height_direction
     1462    print *, x%isccp_overlap
     1463    print *, x%isccp_emsfc_lw
     1464 
     1465    ! RTTOV inputs/options
     1466    print *, x%plat
     1467    print *, x%sat
     1468    print *, x%inst
     1469    print *, x%Nchan
     1470    print *,  'shape(x%Ichan): ',x%Ichan
     1471    print *,  'shape(x%Surfem): ',x%Surfem
     1472    print *, x%ZenAng
     1473    print *, x%co2,x%ch4,x%n2o,x%co
     1474               
     1475END SUBROUTINE COSP_GRIDBOX_PRINT
     1476
     1477SUBROUTINE COSP_MISR_PRINT(x)
     1478    type(cosp_misr),intent(in) :: x
     1479
     1480    print *, '%%%%----- Information on COSP_MISR ------'
     1481               
     1482     ! Dimensions
     1483    print *, x%Npoints
     1484    print *, x%Ntau
     1485    print *, x%Nlevels
     1486
     1487     ! --- (npoints,ntau,nlevels)
     1488     !  the fraction of the model grid box covered by each of the MISR cloud types
     1489     print *,  'shape(x%fq_MISR): ',shape(x%fq_MISR)
     1490     
     1491     ! --- (npoints)
     1492     print *,  'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop)
     1493     print *,  'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea)
     1494     ! --- (npoints,nlevels)
     1495     print *,  'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops)
     1496   
     1497END SUBROUTINE COSP_MISR_PRINT
     1498
     1499SUBROUTINE COSP_ISCCP_PRINT(x)
     1500    type(cosp_isccp),intent(in) :: x
     1501           
     1502    print *, x%Npoints
     1503    print *, x%Ncolumns
     1504    print *, x%Nlevels
     1505
     1506    print *, '%%%%----- Information on COSP_ISCCP ------'
     1507   
     1508     print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp)
     1509     print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea)
     1510     print *, 'shape(x%meantb): ',shape(x%meantb)
     1511     print *, 'shape(x%meantbclr): ',shape(x%meantbclr)
     1512     
     1513     print *, 'shape(x%meanptop): ',shape(x%meanptop)
     1514     print *, 'shape(x%meantaucld): ',shape(x%meantaucld)
     1515     print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld)
     1516     print *, 'shape(x%boxtau): ',shape(x%boxtau)
     1517     print *, 'shape(x%boxptop): ',shape(x%boxptop)
     1518END SUBROUTINE COSP_ISCCP_PRINT
     1519
     1520SUBROUTINE COSP_VGRID_PRINT(x)
     1521    type(cosp_vgrid),intent(in) :: x
     1522           
     1523    print *, '%%%%----- Information on COSP_VGRID ------'
     1524    print *, x%use_vgrid
     1525    print *, x%csat_vgrid
     1526    print *, x%Npoints
     1527    print *, x%Ncolumns
     1528    print *, x%Nlevels
     1529    print *, x%Nlvgrid
     1530    ! Array with dimensions (Nlvgrid)
     1531    print *, 'shape(x%z): ',shape(x%z)
     1532    print *, 'shape(x%zl): ',shape(x%zl)
     1533    print *, 'shape(x%zu): ',shape(x%zu)
     1534    ! Array with dimensions (Nlevels)
     1535    print *, 'shape(x%mz): ',shape(x%mz)
     1536    print *, 'shape(x%mzl): ',shape(x%mzl)
     1537    print *, 'shape(x%mzu): ',shape(x%mzu)
     1538END SUBROUTINE COSP_VGRID_PRINT
     1539
     1540SUBROUTINE COSP_SGLIDAR_PRINT(x)
     1541    type(cosp_sglidar),intent(in) :: x
     1542           
     1543    print *, '%%%%----- Information on COSP_SGLIDAR ------'
     1544    ! Dimensions
     1545    print *, x%Npoints
     1546    print *, x%Ncolumns
     1547    print *, x%Nlevels
     1548    print *, x%Nhydro
     1549    print *, x%Nrefl
     1550    ! Arrays with dimensions (Npoints,Nlevels)
     1551    print *, 'shape(x%beta_mol): ',shape(x%beta_mol)
     1552    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
     1553    print *, 'shape(x%beta_tot): ',shape(x%beta_tot)
     1554    print *, 'shape(x%tau_tot): ',shape(x%tau_tot)
     1555    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
     1556    print *, 'shape(x%refl): ',shape(x%refl)
     1557END SUBROUTINE COSP_SGLIDAR_PRINT
     1558
     1559SUBROUTINE COSP_SGRADAR_PRINT(x)
     1560    type(cosp_sgradar),intent(in) :: x
     1561           
     1562    print *, '%%%%----- Information on COSP_SGRADAR ------'
     1563    print *, x%Npoints
     1564    print *, x%Ncolumns
     1565    print *, x%Nlevels
     1566    print *, x%Nhydro
     1567    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
     1568    ! Arrays with dimensions (Npoints,Nlevels)
     1569    print *, 'shape(x%att_gas): ', shape(x%att_gas)
     1570    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
     1571    print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot)
     1572END SUBROUTINE COSP_SGRADAR_PRINT
     1573
     1574SUBROUTINE COSP_RADARSTATS_PRINT(x)
     1575    type(cosp_radarstats),intent(in) :: x
     1576           
     1577    print *, '%%%%----- Information on COSP_SGRADAR ------'
     1578    print *, x%Npoints
     1579    print *, x%Ncolumns
     1580    print *, x%Nlevels
     1581    print *, x%Nhydro
     1582    print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze)
     1583    print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc)
     1584    print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud)
     1585END SUBROUTINE COSP_RADARSTATS_PRINT
     1586
     1587SUBROUTINE COSP_LIDARSTATS_PRINT(x)
     1588    type(cosp_lidarstats),intent(in) :: x
     1589           
     1590    print *, '%%%%----- Information on COSP_SGLIDAR ------'
     1591    print *, x%Npoints
     1592    print *, x%Ncolumns
     1593    print *, x%Nlevels
     1594    print *, x%Nhydro
     1595    print *, x%Nrefl
     1596   
     1597    ! Arrays with dimensions (SR_BINS)
     1598    print *, 'shape(x%srbval): ',shape(x%srbval)
     1599    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
     1600    print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr)
     1601    ! Arrays with dimensions (Npoints,Nlevels)
     1602    print *, 'shape(x%lidarcld): ',shape(x%lidarcld)
     1603    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
     1604    print *, 'shape(x%cldlayer): ',shape(x%cldlayer)
     1605    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
     1606    print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl)
     1607     ! Arrays with dimensions (Npoints,Nlevels,Nphase)
     1608    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldphase)
     1609     ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
     1610    print *, 'shape(x%cldlayerphase): ',shape(x%cldlayerphase)
     1611     ! Arrays with dimensions (Npoints,Ntemps,Nphase)
     1612    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldtmp)
     1613
     1614END SUBROUTINE COSP_LIDARSTATS_PRINT
     1615
     1616SUBROUTINE COSP_SUBGRID_PRINT(x)
     1617    type(cosp_subgrid),intent(in) :: x
     1618           
     1619    print *, '%%%%----- Information on COSP_SUBGRID ------'
     1620    print *, x%Npoints
     1621    print *, x%Ncolumns
     1622    print *, x%Nlevels
     1623    print *, x%Nhydro
     1624   
     1625    print *, 'shape(x%prec_frac): ',shape(x%prec_frac)
     1626    print *, 'shape(x%frac_out): ',shape(x%frac_out)
     1627END SUBROUTINE COSP_SUBGRID_PRINT
     1628
     1629SUBROUTINE COSP_SGHYDRO_PRINT(x)
     1630    type(cosp_sghydro),intent(in) :: x
     1631           
     1632    print *, '%%%%----- Information on COSP_SGHYDRO ------'
     1633    print *, x%Npoints
     1634    print *, x%Ncolumns
     1635    print *, x%Nlevels
     1636    print *, x%Nhydro
     1637   
     1638    print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro)
     1639    print *, 'shape(x%Reff): ',shape(x%Reff)
     1640    print *, 'shape(x%Np): ',shape(x%Np)         ! added by roj with Quickbeam V3
     1641END SUBROUTINE COSP_SGHYDRO_PRINT
    13781642
    13791643END MODULE MOD_COSP_TYPES

  • LMDZ5/branches/testing/libf/phylmd/cosp/cosp_utils.F90

    r2298 r2435  
    11! (c) British Crown Copyright 2008, the Met Office.
    22! All rights reserved.
     3! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_utils.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    4547!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    4648SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, &
    47                           n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2, &
    48                           flux,mxratio)
     49                          n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, &
     50                          flux,mxratio,reff)
    4951
    5052    ! Input arguments, (IN)
    … …  
    5254    real,intent(in),dimension(Npoints,Nlevels) :: p,T,flux
    5355    real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
    54     real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,prec_type
     56    real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type
    5557    ! Input arguments, (OUT)
    5658    real,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
     59    real,intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff
    5760    ! Local variables
    5861    integer :: i,j,k
    59     real :: sigma,one_over_xip1,xi,rho0,rho
     62    real :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta
    6063   
    6164    mxratio = 0.0
    6265
    6366    if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
    64         !gamma1  = gamma(alpha_x + b_x + d_x + 1.0)
    65         !gamma2  = gamma(alpha_x + b_x + 1.0)
    6667        xi      = d_x/(alpha_x + b_x - n_bx + 1.0)
    6768        rho0    = 1.29
    6869        sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
    6970        one_over_xip1 = 1.0/(xi + 1.0)
     71        gamma_4_3_2 = 0.5*gamma4/gamma3
     72        delta = (alpha_x + b_x + d_x - n_bx + 1.0)
    7073       
    7174        do k=1,Nlevels
    … …  
    7679                        mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1
    7780                        mxratio(i,j,k)=mxratio(i,j,k)/rho
     81                        ! Compute effective radius
     82                        if ((reff(i,j,k) <= 0.0).and.(flux(i,k) /= 0.0)) then
     83                           lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1./delta)
     84                           reff(i,j,k) = gamma_4_3_2/lambda_x
     85                        endif
    7886                    endif
    7987                enddo

  • LMDZ5/branches/testing/libf/phylmd/cosp/dsd.F90

    r2298 r2435  
    1   subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, &
    2              dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled)
     1  subroutine dsd(Q,Re,Np,D,N,nsizes,dtype,rho_a,tk, &
     2             dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
    33  use array_lib
    44  use math_lib
    … …  
    77! Purpose:
    88!   Create a discrete drop size distribution
    9 !   Part of QuickBeam v1.03 by John Haynes
     9!
     10!   Starting with Quickbeam V3, this routine now allows input of
     11!   both effective radius (Re) and total number concentration (Nt)
     12!   Roj Marchand July 2010
     13!
     14!   The version in Quickbeam v.104 was modified to allow Re but not Nt
     15!   This is a significantly modified form for the version     
     16!
     17!   Originally Part of QuickBeam v1.03 by John Haynes
    1018!   http://reef.atmos.colostate.edu/haynes/radarsim
    1119!
    1220! Inputs:
     21!
    1322!   [Q]        hydrometeor mixing ratio (g/kg)
    14 !   [Re]       Optional Effective Radius (microns).  0 = use default.
    15 !   [D]        discrete drop sizes (um)
     23!   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
     24!
     25!   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
    1626!   [nsizes]   number of elements of [D]
     27!
    1728!   [dtype]    distribution type
    1829!   [rho_a]    ambient air density (kg m^-3)
    19 !   [tc]       temperature (C)
     30!   [tk]       temperature (K)
    2031!   [dmin]     minimum size cutoff (um)
    2132!   [dmax]     maximum size cutoff (um)
    … …  
    2435!
    2536! Input/Output:
    26 !   [fc]       scaling factor for the distribution
    27 !   [scaled]   has this hydrometeor type been scaled?
    2837!   [apm]      a parameter for mass (kg m^[-bpm])
    2938!   [bmp]      b params for mass
    … …  
    4150!   01/31/06  Port from IDL to Fortran 90
    4251!   07/07/06  Rewritten for variable DSD's
    43 !   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH)
     52!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
     53!   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).
    4454 
    4555! ----- INPUTS ----- 
    4656 
    47   integer*4, intent(in) :: nsizes
     57  integer, intent(in) :: nsizes
    4858  integer, intent(in) :: dtype
    49   real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, &
    50     rho_c,p1,p2,p3
    51    
    52 ! ----- INPUT/OUTPUT -----
    53 
    54   real*8, intent(inout) :: fc(nsizes),apm,bpm,Re
    55   logical, intent(inout) :: scaled 
    56    
     59  real*8, intent(in)  :: Q,Re,Np,D(nsizes)
     60  real*8, intent(in)  :: rho_a,tk,dmin,dmax,rho_c,p1,p2,p3
     61   
     62  real*8, intent(inout) :: apm,bpm 
     63 
    5764! ----- OUTPUTS -----
    5865
    … …  
    6067 
    6168! ----- INTERNAL -----
    62  
     69 
     70   real*8 :: fc(nsizes)
     71
    6372  real*8 :: &
    64   N0,D0,vu,np,dm,ld, &                  ! gamma, exponential variables
    65   dmin_mm,dmax_mm,ahp,bhp, &            ! power law variables
    66   rg,log_sigma_g, &                     ! lognormal variables
    67   rho_e                                 ! particle density (kg m^-3)
     73  N0,D0,vu,local_np,dm,ld, &            ! gamma, exponential variables
     74  dmin_mm,dmax_mm,ahp,bhp, &        ! power law variables
     75  rg,log_sigma_g, &         ! lognormal variables
     76  rho_e                 ! particle density (kg m^-3)
    6877 
    6978  real*8 :: tmp1, tmp2
    70   real*8 :: pi,rc
     79  real*8 :: pi,rc,tc
    7180
    7281  integer k,lidx,uidx
    7382
     83  tc = tk - 273.15
    7484  pi = acos(-1.0)
    7585 
    76 ! // if density is constant, store equivalent values for apm and bpm
     86  ! // if density is constant, store equivalent values for apm and bpm
    7787  if ((rho_c > 0) .and. (apm < 0)) then
    7888    apm = (pi/6)*rho_c
    … …  
    8090  endif
    8191 
     92  ! will preferentially use Re input over Np.
     93  ! if only Np given then calculate Re
     94  ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
     95  if(Re==0 .and. Np>0) then
     96   
     97        call calc_Re(Q,Np,rho_a, &
     98             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
     99             Re)
     100  endif
     101 
     102 
    82103  select case(dtype)
    83104 
    … …  
    85106! // modified gamma                                        !
    86107! ---------------------------------------------------------!
    87 ! :: N0 = total number concentration (m^-3)
    88 ! :: np = fixed number concentration (kg^-1)
     108! :: np = total number concentration
    89109! :: D0 = characteristic diameter (um)
    90 ! :: dm = mean diameter (um)
     110! :: dm = mean diameter (um) - first moment over zeroth moment
    91111! :: vu = distribution width parameter
    92112
    93113  case(1) 
    94     if (abs(p1+1) < 1E-8) then
    95 
    96 !     // D0, vu are given 
     114 
     115    if( abs(p3+2) < 1E-8) then
     116 
     117    if( Np>1E-30) then
     118   
     119        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
     120        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
     121        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2.0 ! units of Nt = Np*rhoa = #/cm^3
     122    else
     123        print *, 'Error: Must specify a value for Np in each volume', &
     124             ' with Morrison/Martin Scheme.'
     125            stop   
     126    endif
     127   
     128    elseif (abs(p3+1) > 1E-8) then
     129
     130      ! vu is fixed in hp structure 
    97131      vu = p3
    98      
    99       if(Re.le.0) then
    100         dm = p2
    101         D0 = gamma(vu)/gamma(vu+1)*dm
    102       else
    103         D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
    104       endif
    105      
    106       if (scaled .eqv. .false.) then
    107      
     132
     133    else
     134
     135      ! vu isn't specified
     136     
     137      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
     138      stop   
     139     
     140    endif
     141     
     142      if(Re>0) then
     143
     144    D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
     145   
    108146        fc = ( &
    109147             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
    110148             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
    111              ) * 1E-12
    112         scaled = .true.
    113 
    114       endif       
    115 
    116       N = fc*rho_a*(Q*1E-3)
    117    
    118     elseif (abs(p2+1) < 1E-8) then
    119 
    120 !     // N0, vu are given   
    121       np = p1
    122       vu = p3
    123       tmp1 = (Q*1E-3)**(1./bpm)
    124      
    125       if (scaled .eqv. .false.) then
    126 
    127         fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** &
     149         ) * 1E-12
     150
     151        N = fc*rho_a*(Q*1E-3)
     152       
     153      elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter
     154     
     155        dm = p2
     156    D0 = gamma(vu)/gamma(vu+1)*dm
     157
     158        fc = ( &
     159             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
     160             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
     161         ) * 1E-12
     162
     163        N = fc*rho_a*(Q*1E-3)
     164       
     165      elseif(abs(p3+1) > 1E-8)  then! use default number concentration
     166   
     167        local_np = p1 ! total number concentration / pa check
     168   
     169    tmp1 = (Q*1E-3)**(1./bpm)
     170     
     171        fc = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))** &
    128172             (1./bpm))**vu
    129              
    130         scaled = .true.
    131 
     173         
     174        N = ( &
     175          (rho_a*local_np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
     176          exp(-1.*fc**(1./vu)/tmp1) &
     177      ) * 1E-12
     178
     179      else
     180     
     181        print *, 'Error:  No default value for Dm or Np provided!  '
     182        stop
     183       
    132184      endif
    133 
    134       N = ( &
    135           (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
    136           exp(-1.*fc**(1./vu)/tmp1) &
    137           ) * 1E-12
    138 
    139     else
    140 
    141 !     // vu isn't given
    142       print *, 'Error: Must specify a value for vu'
    143       stop
    144    
    145     endif
     185   
    146186   
    147187! ---------------------------------------------------------!
    … …  
    152192
    153193  case(2)
    154     if (abs(p1+1) > 1E-8) then
    155 
    156 !     // N0 has been specified, determine ld
    157       N0 = p1
    158 
    159       if(Re>0) then
    160 
    161         ! if Re is set and No is set than the distribution is fully defined.
    162         ! so we assume Re and No have already been chosen consistant with 
    163         ! the water content, Q.
    164 
    165         ! print *,'using Re pass ...'
    166 
    167         ld = 1.5/Re   ! units 1/um
    168 
    169         N = ( &
    170                 N0*exp(-1*ld*D) &
    171         ) * 1E-12
    172    
    173       else
    174 
    175         tmp1 = 1./(1.+bpm)
    176      
    177         if (scaled .eqv. .false.) then
    178                 fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
    179                 scaled = .true.
    180 
    181         endif
     194 
     195    if(Re>0) then
     196 
     197        ld = 1.5/Re   ! units 1/um
     198       
     199    fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
     200               exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
    182201     
    183         N = ( &
    184                 N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
    185         ) * 1E-12
    186 
    187       endif     
     202        N = fc*rho_a*(Q*1E-3)
     203       
     204    elseif (abs(p1+1) > 1E-8) then
     205
     206    ! use N0 default value
     207   
     208        N0 = p1
     209
     210        tmp1 = 1./(1.+bpm)
     211 
     212        fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
     213 
     214        N = ( &
     215            N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
     216    ) * 1E-12
    188217
    189218    elseif (abs(p2+1) > 1E-8) then
    190219
    191 !     // ld has been specified, determine N0
    192       ld = p2
    193 
    194       if (scaled .eqv. .false.) then
     220    !     used default value for lambda
     221        ld = p2
    195222
    196223        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
    197224             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
    198         scaled = .true.
    199 
    200       endif
    201 
    202       N = fc*rho_a*(Q*1E-3)
    203 
    204     else
    205 
    206 !     // ld will be determined from temperature, then N0 follows
     225     
     226        N = fc*rho_a*(Q*1E-3)
     227
     228    else
     229
     230      !  ld "parameterized" from temperature (carry over from original Quickbeam).
    207231      ld = 1220*10.**(-0.0245*tc)*1E-6
    208232      N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
    … …  
    223247
    224248  case(3)
     249 
     250    if(Re>0) then
     251        print *, 'Variable Re not supported for ', &
     252         'Power-Law distribution'
     253    stop
     254    elseif(Np>0) then
     255        print *, 'Variable Np not supported for ', &
     256         'Power-Law distribution'
     257    stop
     258    endif
    225259
    226260!   :: br parameter
    … …  
    257291
    258292!   :: commented lines are original method with constant density
    259       ! rc = 500.               ! (kg/m^3)
     293      ! rc = 500.       ! (kg/m^3)
    260294      ! tmp1 = 6*rho_a*(bhp+4)
    261295      ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
    … …  
    273307      do k=lidx,uidx
    274308 
    275         N(k) = ( &
     309        N(k) = ( &
    276310        ahp*(D(k)*1E-3)**bhp &
    277         ) * 1E-12   
     311    ) * 1E-12   
    278312
    279313      enddo
    280314
    281         ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm
     315    ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm
    282316
    283317! ---------------------------------------------------------!
    … …  
    288322  case(4)
    289323 
    290     if (scaled .eqv. .false.) then
    291    
    292       D0 = p1
     324    if (Re>0) then
     325        D0 = Re
     326    else
     327        D0 = p1
     328    endif
     329   
    293330      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
    294331      fc(1) = (6./(pi*D0**3*rho_e))*1E12
    295       scaled = .true.
    296      
    297     endif
    298    
    299     N(1) = fc(1)*rho_a*(Q*1E-3)
     332      N(1) = fc(1)*rho_a*(Q*1E-3)
    300333   
    301334! ---------------------------------------------------------!
    … …  
    308341
    309342  case(5)
    310     if (abs(p1+1) < 1E-8) then
     343    if (abs(p1+1) < 1E-8 .or. Re>0 ) then
    311344
    312345!     // rg, log_sigma_g are given
    … …  
    314347      tmp2 = (bpm*log_sigma_g)**2.
    315348      if(Re.le.0) then
    316         rg = p2
    317       else
    318         rg =Re*exp(-2.5*(log_sigma_g**2))
     349        rg = p2
     350      else
     351    rg =Re*exp(-2.5*(log_sigma_g**2))
    319352      endif
    320353 
    321       if (scaled .eqv. .false.) then
    322            
    323         fc = 0.5 * ( &
    324              (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
    325              log_sigma_g*D*0.5*1E-6)) * &
    326              exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
    327              ) * 1E-12
    328         scaled = .true.
    329              
     354         fc = 0.5 * ( &
     355         (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
     356         log_sigma_g*D*0.5*1E-6)) * &
     357         exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
     358         ) * 1E-12
     359               
     360      N = fc*rho_a*(Q*1E-3)
     361     
     362    elseif (abs(p2+1) < 1E-8 .or. Np>0) then
     363
     364!     // Np, log_sigma_g are given   
     365      if(Np>0) then
     366        local_Np=Np
     367      else
     368        local_Np = p1
    330369      endif
    331                
    332       N = fc*rho_a*(Q*1E-3)
    333      
    334     elseif (abs(p2+1) < 1E-8) then
    335 
    336 !     // N0, log_sigma_g are given   
    337       Np = p1
     370     
    338371      log_sigma_g = p3
    339       N0 = np*rho_a
     372      N0 = local_np*rho_a
    340373      tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
    341374      tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.     
    … …  
    344377      N = 0.5*( &
    345378        N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
    346         exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
    347         ) * 1E-12     
    348      
    349     else
    350 
    351 !     // vu isn't given
     379    exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
     380    ) * 1E-12     
     381     
     382    else
     383
    352384      print *, 'Error: Must specify a value for sigma_g'
    353385      stop

  • LMDZ5/branches/testing/libf/phylmd/cosp/format_input.F90

    r2298 r2435  
     1! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/format_input.f90 $
    13! FORMAT_INPUT: Procedures to prepare data for input to the simulator
    24! Compiled/Modified:

  • LMDZ5/branches/testing/libf/phylmd/cosp/gases.F90

    r2298 r2435  
     1! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/gases.f90 $
    13  function gases(PRES_mb,T,RH,f)
    24  implicit none
    … …  
    3032  real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6
    3133  real*8, dimension(nbands_h2o) :: v1, b1, b2, b3
     34  real*8 :: e_th,one_th,pth3,eth35,aux1,aux2,aux3,aux4
     35  real*8 :: gm,delt,x,y,gm2
     36  real*8 :: fpp_o2,fpp_h2o,s_o2,s_h2o
    3237  integer :: i
    3338 
    … …  
    110115 
    111116! // conversions
    112   th = 300./T           ! unitless
    113   e = (RH*th**5)/(41.45*10**(9.834*th-10))      ! kPa
    114   p = PRES_mb/10.-e     ! kPa
     117  th = 300./T       ! unitless
     118  e = (RH*th**5)/(41.45*10**(9.834*th-10))   ! kPa
     119  p = PRES_mb/10.-e ! kPa
     120  e_th = e*th
     121  one_th = 1 - th
     122  pth3 = p*th**(3)
     123  eth35 = e*th**(3.5)
    115124
    116125! // term1
    117126  sumo = 0.
     127  aux1 = 1.1*e_th
    118128  do i=1,nbands_o2
    119     sumo = sumo + fpp_o2(p,th,e,a3(i),a4(i),a5(i),a6(i),f,v0(i)) &
    120            * s_o2(p,th,a1(i),a2(i))
     129    aux2 = f/v0(i)
     130    aux3 = v0(i)-f
     131    aux4 = v0(i)+f
     132    gm = a3(i)*(p*th**(0.8-a4(i))+aux1)
     133    gm2 = gm**2
     134    delt = a5(i)*p*th**a6(i)
     135    x = aux3**2+gm2
     136    y = aux4**2+gm2
     137    fpp_o2 = (((1./x)+(1./y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x))))
     138    s_o2 = a1(i)*pth3*exp(a2(i)*one_th)
     139    sumo = sumo + fpp_o2 * s_o2
    121140  enddo
    122141  term1 = sumo
    … …  
    131150! // term3
    132151  sumo = 0.
     152  aux1 = 4.8*e_th
    133153  do i=1,nbands_h2o
    134     sumo = sumo + fpp_h2o(p,th,e,b3(i),f,v1(i)) &
    135            * s_h2o(th,e,b1(i),b2(i))
     154    aux2 = f/v1(i)
     155    aux3 = v1(i)-f
     156    aux4 = v1(i)+f
     157    gm = b3(i)*(p*th**(0.8)+aux1)
     158    gm2 = gm**2
     159    x = aux3**2+gm2
     160    y = aux4**2+gm2
     161    !delt = 0.
     162    fpp_h2o = ((1./x)+(1./y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x)))
     163    s_h2o = b1(i)*eth35*exp(b2(i)*one_th)
     164    sumo = sumo + fpp_h2o * s_h2o
    136165  enddo
    137166  term3 = sumo
    … …  
    146175  gases = 0.182*f*npp
    147176
    148 ! ----- SUB FUNCTIONS -----
    149    
    150   contains
    151  
    152   function fpp_o2(p,th,e,a3,a4,a5,a6,f,v0)
    153   real*8 :: fpp_o2,p,th,e,a3,a4,a5,a6,f,v0
    154   real*8 :: gm, delt, x, y
    155   gm = a3*(p*th**(0.8-a4)+1.1*e*th)
    156   delt = a5*p*th**(a6)
    157   x = (v0-f)**2+gm**2
    158   y = (v0+f)**2+gm**2
    159   fpp_o2 = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x))) 
    160   end function fpp_o2
    161  
    162   function fpp_h2o(p,th,e,b3,f,v0)
    163   real*8 :: fpp_h2o,p,th,e,b3,f,v0
    164   real*8 :: gm, delt, x, y
    165   gm = b3*(p*th**(0.8)+4.8*e*th)
    166   delt = 0.
    167   x = (v0-f)**2+gm**2
    168   y = (v0+f)**2+gm**2
    169   fpp_h2o = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))
    170   end function fpp_h2o
    171  
    172   function s_o2(p,th,a1,a2)
    173   real*8 :: s_o2,p,th,a1,a2
    174   s_o2 = a1*p*th**(3)*exp(a2*(1-th))
    175   end function s_o2
    176 
    177   function s_h2o(th,e,b1,b2)
    178   real*8 :: s_h2o,th,e,b1,b2
    179   s_h2o = b1*e*th**(3.5)*exp(b2*(1-th))
    180   end function s_h2o
    181  
    182177  end function gases

  • LMDZ5/branches/testing/libf/phylmd/cosp/icarus.F

    r2298 r2435  
     1! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/icarus.f $
    13      SUBROUTINE ICARUS(
    24     &     debug,

  • LMDZ5/branches/testing/libf/phylmd/cosp/lidar_simulator.F90

    r2298 r2435  
    11! Copyright (c) 2009, Centre National de la Recherche Scientifique
    22! All rights reserved.
     3! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lidar_simulator.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    2830                , q_lsliq, q_lsice, q_cvliq, q_cvice &
    2931                , ls_radliq, ls_radice, cv_radliq, cv_radice &
    30                 , frac_out, ice_type &
    31                 , pmol, pnorm, tautot, refl )
     32                , ice_type, pmol, pnorm, pnorm_perp_tot,tautot, refl )
    3233!
    3334!---------------------------------------------------------------------------------
    … …  
    7576! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2
    7677! was missing. This affects the ATB values but not the cloud fraction.
     78!
     79! January 2013, G. Cesana and H. Chepfer:
     80! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments
     81! - Add the temperature for each levels (temp) in the arguments
     82! - Add the computation of the perpendicular component of the backscattered lidar signal
     83! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
     84! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
    7785!
    7886!---------------------------------------------------------------------------------
    … …  
    96104!  cv_radliq: effective radius of CONV liquid particles (meters)
    97105!  cv_radice: effective radius of CONV ice particles (meters)
    98 !  frac_out : cloud cover in each sub-column of the gridbox (output from scops)
    99106!  ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1
    100107!             for non spherical particles)
    … …  
    103110!  pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1)
    104111!  pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1)
     112!  pnorm_perp_tot: perpendicular attenuated backscatter lidar signal power (m^-1.sr^-1)
    105113!  tautot: optical thickess integrated from top to level z
    106114!  refl : parasol(polder) reflectance
    … …  
    130138      REAL pres(npoints,nlev)    ! pressure full levels
    131139      REAL presf(npoints,nlev+1) ! pressure half levels
    132       REAL temp(npoints,nlev)
    133140      REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev)
    134141      REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev)
    135142      REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev)
    136143      REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev)
    137       REAL frac_out(npoints,nlev)
    138144
    139145! outputs (for each subcolumn):
    … …  
    168174
    169175!   sub-column variables:
    170       REAL frac_sub(npoints,nlev)
    171176      REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn
    172177      REAL alpha_part(npoints,nlev,npart)
    … …  
    177182      REAL tautot_lay(npoints)   ! temporary variable, total opt. thickness of layer k
    178183!     Optical thickness from TOA to surface for Parasol
    179       REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds
    180 
    181 ! Abderrahmane 8-2-2011
    182       Logical iflag_testlidar
    183       PARAMETER (iflag_testlidar=.false.)
     184     REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds
     185
     186
     187! Local variables
     188      REAL Alpha, Beta, Gamma  ! Polynomial coefficient for ATBperp computation
     189      REAL temp(npoints,nlev)                   ! temperature of layer k
     190      REAL betatot_ice(npoints,nlev)    ! backscatter coefficient for ice particles
     191      REAL beta_perp_ice(npoints,nlev)  ! perpendicular backscatter coefficient for ice
     192      REAL betatot_liq(npoints,nlev)    ! backscatter coefficient for liquid particles
     193      REAL beta_perp_liq(npoints,nlev)  ! perpendicular backscatter coefficient for liq
     194      REAL tautot_ice(npoints,nlev)     ! total optical thickness of ice
     195      REAL tautot_liq(npoints,nlev)     ! total optical thickness of liq
     196      REAL tautot_lay_ice(npoints)    ! total optical thickness of ice in the layer k
     197      REAL tautot_lay_liq(npoints)    ! total optical thickness of liq in the layer k
     198      REAL pnorm_liq(npoints,nlev)    ! lidar backscattered signal power for liquid
     199      REAL pnorm_ice(npoints,nlev)    ! lidar backscattered signal power for ice
     200      REAL pnorm_perp_ice(npoints,nlev) ! perpendicular lidar backscattered signal power for ice
     201      REAL pnorm_perp_liq(npoints,nlev) ! perpendicular lidar backscattered signal power for liq
     202
     203! Output variable
     204      REAL pnorm_perp_tot (npoints,nlev) ! perpendicular lidar backscattered signal power
     205
     206!------------------------------------------------------------
     207!---- 0. Initialisation :
     208!------------------------------------------------------------
     209betatot_ice(:,:)=0
     210betatot_liq(:,:)=0
     211beta_perp_ice(:,:)=0
     212beta_perp_liq(:,:)=0
     213tautot_ice(:,:)=0
     214tautot_liq(:,:)=0
     215tautot_lay_ice(:)=0;
     216tautot_lay_liq(:)=0;
     217pnorm_liq(:,:)=0
     218pnorm_ice(:,:)=0
     219pnorm_perp_ice(:,:)=0
     220pnorm_perp_liq(:,:)=0
     221pnorm_perp_tot(:,:)=0
     222
     223
     224! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the ATBperpendicular
     225! as a function of the ATB for ice or liquid cloud particles derived from CALIPSO-GOCCP
     226! observations at 120m vertical grid (Cesana and Chepfer, JGR, 2013).
     227!
     228! Relationship between ATBice and ATBperp,ice for ice particles
     229!  ATBperp,ice = Alpha*ATBice
     230         Alpha = 0.2904
     231
     232! Relationship between ATBice and ATBperp,ice for liquid particles
     233!  ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
     234         Beta = 0.4099
     235         Gamma = 0.009
    184236
    185237!------------------------------------------------------------
    … …  
    201253! We repeat the same coefficients for LS and CONV cloud to make code more readable
    202254!*     LS Liquid water coefficients:
    203          polpart(INDX_LSLIQ,1) =  2.6980e-8     
     255         polpart(INDX_LSLIQ,1) =  2.6980e-8
    204256         polpart(INDX_LSLIQ,2) = -3.7701e-6
    205257         polpart(INDX_LSLIQ,3) =  1.6594e-4
    … …  
    208260!*     LS Ice coefficients:
    209261      if (ice_type.eq.0) then     
    210          polpart(INDX_LSICE,1) = -1.0176e-8   
     262         polpart(INDX_LSICE,1) = -1.0176e-8
    211263         polpart(INDX_LSICE,2) =  1.7615e-6
    212264         polpart(INDX_LSICE,3) = -1.0480e-4
    … …  
    216268!*     LS Ice NS coefficients:
    217269      if (ice_type.eq.1) then
    218          polpart(INDX_LSICE,1) = 1.3615e-8 
    219          polpart(INDX_LSICE,2) = -2.04206e-6 
     270         polpart(INDX_LSICE,1) = 1.3615e-8
     271         polpart(INDX_LSICE,2) = -2.04206e-6
    220272         polpart(INDX_LSICE,3) = 7.51799e-5
    221273         polpart(INDX_LSICE,4) = 0.00078213
    … …  
    223275      endif
    224276!*     CONV Liquid water coefficients:
    225          polpart(INDX_CVLIQ,1) =  2.6980e-8     
     277         polpart(INDX_CVLIQ,1) =  2.6980e-8
    226278         polpart(INDX_CVLIQ,2) = -3.7701e-6
    227279         polpart(INDX_CVLIQ,3) =  1.6594e-4
    … …  
    230282!*     CONV Ice coefficients:
    231283      if (ice_type.eq.0) then
    232          polpart(INDX_CVICE,1) = -1.0176e-8   
     284         polpart(INDX_CVICE,1) = -1.0176e-8
    233285         polpart(INDX_CVICE,2) =  1.7615e-6
    234286         polpart(INDX_CVICE,3) = -1.0480e-4
    … …  
    268320                  -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81)
    269321      enddo
    270 
    271 ! cloud fraction (0 or 1) in each sub-column:
    272 ! (if frac_out=1or2 -> frac_sub=1; if frac_out=0 -> frac_sub=0)
    273       frac_sub = MIN( frac_out, 1.0 )
    274322
    275323!------------------------------------------------------------
    … …  
    316364
    317365!------------------------------------------------------------
    318 !---- 4. Backscatter signal:
     366!---- 4.1 Total Backscatter signal:
    319367!------------------------------------------------------------
    320368
    … …  
    356404        END WHERE
    357405      END DO
    358 !
     406
    359407! Total signal (molecular + particules):
     408!
    360409!
    361410! For performance reason on vector computers, the 2 following lines should not be used
    … …  
    373422      pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) &
    374423            & * (1.-exp(-2.0*tautot(:,nlev)))
     424
    375425!     Other layers
    376426      DO k= nlev-1, 1, -1
    377         tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
     427          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
    378428        WHERE (tautot_lay(:).GT.0.)
    379        pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
    380 !correc          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) & ! correc Satoh
    381 !correc               &               / (2.0*tautot_lay(:)) &          ! correc Satoh
     429          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
    382430               & * (1.-EXP(-2.0*tautot_lay(:)))
    383431        ELSEWHERE
    … …  
    387435      END DO
    388436
    389      if (iflag_testlidar) then
    390 !+JLD test
    391 !     do k=1,nlev
    392 !      print*,'Min val de frac_out=',k,minval(frac_out(:,k))
    393 !      print*,'Max val de frac_out=',k,maxval(frac_out(:,k))
    394 !     enddo
    395        where ( frac_out(:,:).ge.0.5)
    396 ! Correction AI 9 5 11          pnorm(:,:) = pmol(:,:)*10.
    397        pnorm(:,:) = pmol(:,:)*50.
    398         elsewhere
    399           pnorm(:,:) = pmol(:,:)
    400         endwhere
    401 !-JLD test
    402      endif
     437!------------------------------------------------------------
     438!---- 4.2 Ice/Liq Backscatter signal:
     439!------------------------------------------------------------
     440
     441! Contribution of the molecular to beta
     442      betatot_ice(:,:) = beta_mol(:,:)
     443      betatot_liq(:,:) = beta_mol(:,:)
     444
     445      tautot_ice(:,:) = tau_mol(:,:)
     446      tautot_liq(:,:) = tau_mol(:,:)
     447
     448      DO i = 2, npart,2
     449           betatot_ice(:,:) = betatot_ice(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
     450           tautot_ice(:,:) = tautot_ice(:,:)  + tau_part(:,:,i)
     451      ENDDO ! i
     452      DO i = 1, npart,2
     453           betatot_liq(:,:) = betatot_liq(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
     454           tautot_liq(:,:) = tautot_liq(:,:)  + tau_part(:,:,i)
     455      ENDDO ! i
     456
     457
     458! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq)
     459!     Ice only
     460!     Upper layer
     461      pnorm_ice(:,nlev) = betatot_ice(:,nlev) / (2.*tautot_ice(:,nlev)) &
     462            & * (1.-exp(-2.0*tautot_ice(:,nlev)))
     463
     464      DO k= nlev-1, 1, -1
     465          tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1)
     466        WHERE (tautot_lay_ice(:).GT.0.)
     467         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))/(2.*tautot_lay_ice(:)) &
     468               & * (1.-EXP(-2.0*tautot_lay_ice(:)))
     469        ELSEWHERE
     470         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))
     471        END WHERE
     472      ENDDO
     473
     474!     Liquid only
     475!     Upper layer
     476      pnorm_liq(:,nlev) = betatot_liq(:,nlev) / (2.*tautot_liq(:,nlev)) &
     477            & * (1.-exp(-2.0*tautot_liq(:,nlev)))
     478
     479      DO k= nlev-1, 1, -1
     480          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1)
     481        WHERE (tautot_lay_liq(:).GT.0.)
     482          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))/(2.*tautot_lay_liq(:)) &
     483               & * (1.-EXP(-2.0*tautot_lay_liq(:)))
     484        ELSEWHERE
     485          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))
     486        END WHERE
     487      ENDDO
     488
     489
     490! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering
     491! contribution (Cesana and Chepfer 2013, JGR)
     492!  ATBperp,ice = Alpha*ATBice
     493!  ATBperp,liq = Beta*ATBliq^2 + Gamma*ATBliq
     494
     495      DO k= nlev, 1, -1
     496              pnorm_perp_ice(:,k) = Alpha * pnorm_ice(:,k) ! Ice particles
     497              pnorm_perp_liq(:,k) = 1000*Beta * pnorm_liq(:,k)**2 + Gamma * pnorm_liq(:,k) ! Liquid particles
     498      ENDDO
     499
     500! Computation of beta_perp_ice/liq using the lidar equation
     501!     Ice only
     502!     Upper layer
     503      beta_perp_ice(:,nlev) = pnorm_perp_ice(:,nlev) * (2.*tautot_ice(:,nlev)) &
     504            & / (1.-exp(-2.0*tautot_ice(:,nlev)))
     505
     506      DO k= nlev-1, 1, -1
     507        tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1)
     508        WHERE (tautot_lay_ice(:).GT.0.)
     509         beta_perp_ice(:,k) = pnorm_perp_ice(:,k)/ EXP(-2.0*tautot_ice(:,k+1)) * (2.*tautot_lay_ice(:)) &
     510            & / (1.-exp(-2.0*tautot_lay_ice(:)))
     511
     512        ELSEWHERE
     513         beta_perp_ice(:,k)=pnorm_perp_ice(:,k)/EXP(-2.0*tautot_ice(:,k+1))
     514        END WHERE
     515      ENDDO
     516
     517!     Liquid only
     518!     Upper layer
     519      beta_perp_liq(:,nlev) = pnorm_perp_liq(:,nlev) * (2.*tautot_liq(:,nlev)) &
     520            & / (1.-exp(-2.0*tautot_liq(:,nlev)))
     521
     522      DO k= nlev-1, 1, -1
     523          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1)
     524        WHERE (tautot_lay_liq(:).GT.0.)
     525         beta_perp_liq(:,k) = pnorm_perp_liq(:,k)/ EXP(-2.0*tautot_liq(:,k+1)) * (2.*tautot_lay_liq(:)) &
     526            & / (1.-exp(-2.0*tautot_lay_liq(:)))
     527
     528        ELSEWHERE
     529         beta_perp_liq(:,k)=pnorm_perp_liq(:,k)/EXP(-2.0*tautot_liq(:,k+1))
     530        END WHERE
     531      ENDDO
     532
     533
     534
     535!------------------------------------------------------------
     536!---- 4.3 Perpendicular Backscatter signal:
     537!------------------------------------------------------------
     538
     539! Computation of the total perpendicular lidar signal (ATBperp for liq+ice)
     540!     Upper layer
     541    WHERE(tautot(:,nlev).GT.0)
     542          pnorm_perp_tot(:,nlev) = &
     543              (beta_perp_ice(:,nlev)+beta_perp_liq(:,nlev)-(beta_mol(:,nlev)/(1+1/0.0284))) / (2.*tautot(:,nlev)) &
     544              & * (1.-exp(-2.0*tautot(:,nlev)))
     545    ELSEWHERE
     546    pnorm_perp_tot(:,nlev) = 0.
     547    ENDWHERE
     548
     549!     Other layers
     550      DO k= nlev-1, 1, -1
     551          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
     552
     553          ! The perpendicular component of the molecular backscattered signal (Betaperp) has been
     554          ! taken into account two times (once for liquid and once for ice).
     555          ! We remove one contribution using
     556          ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following equations:
     557            WHERE (pnorm(:,k).eq.0)
     558                  pnorm_perp_tot(:,k)=0.
     559                  ELSEWHERE
     560                    WHERE (tautot_lay(:).GT.0.)
     561                      pnorm_perp_tot(:,k) = &
     562                          (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
     563                          EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
     564                          & * (1.-EXP(-2.0*tautot_lay(:)))
     565                    ELSEWHERE
     566          !         This must never happen, but just in case, to avoid div. by 0
     567                      pnorm_perp_tot(:,k) = &
     568                           (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
     569                          EXP(-2.0*tautot(:,k+1))
     570                    END WHERE
     571            ENDWHERE
     572
     573      END DO
    403574
    404575!-------- End computation Lidar --------------------------

  • LMDZ5/branches/testing/libf/phylmd/cosp/llnl_stats.F90

    r2298 r2435  
    11! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
    22! All rights reserved.
     3! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/llnl_stats.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    2224! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
    2325! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     26!
     27! History
     28!
     29! Jan 2013 - G. Cesana        - Added betaperp_tot and temp_tot arguments
     30!
     31
    2432
    2533MODULE MOD_LLNL_STATS
    … …  
    8189!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
    8290!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    83 SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
     91SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,temp_tot,beta_tot, &
     92                   betaperp_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
    8493   ! Input arguments
    8594   integer,intent(in) :: Npoints,Ncolumns,Nlevels
    8695   real,dimension(Npoints,Nlevels),intent(in) :: beta_mol   ! Molecular backscatter
    8796   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot   ! Total backscattered signal
     97   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: temp_tot   ! Total backscattered signal
     98   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: betaperp_tot   ! perpendicular Total backscattered signal
    8899   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot     ! Radar reflectivity
    89100   ! Output arguments
    90101   real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud
    91102   real,dimension(Npoints),intent(out) :: tcc
    92    
     103
    93104   ! local variables
    94105   real :: sc_ratio
    95106   real :: s_cld, s_att
    96 !      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
    97    parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
     107   parameter (S_cld = 5.0)
    98108   parameter (s_att = 0.01)
    99109   integer :: flag_sat !first saturated level encountered from top
    100110   integer :: flag_cld !cloudy column
    101111   integer :: pr,i,j
    102    
     112
    103113   lidar_only_freq_cloud = 0.0
    104114   tcc = 0.0
    … …  
    109119       do j=Nlevels,1,-1 !top->surf
    110120        sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
    111 !         if ((pr == 1).and.(j==8)) print *, pr,i,j,sc_ratio,Ze_tot(pr,i,j)
    112121        if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
    113122        if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
    114123         if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
    115 !             if ((pr == 1).and.(j==8)) print *, 'L'
    116124            lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
    117125            flag_cld=1
    118126         endif
    119127        else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
    120 !            if ((pr == 1).and.(j==8)) print *, 'R'
    121128           flag_cld=1
    122129        endif
    … …  
    124131       if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1.
    125132     enddo !columns
    126 !      if (tcc(pr) > Ncolumns) then
    127 !      print *, 'tcc(',pr,'): ', tcc(pr)
    128 !      tcc(pr) = Ncolumns
    129 !      endif
    130133   enddo !points
    131134   lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns

  • LMDZ5/branches/testing/libf/phylmd/cosp/lmd_ipsl_stats.F90

    r2298 r2435  
    11! Copyright (c) 2009, Centre National de la Recherche Scientifique
    22! All rights reserved.
     3! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lmd_ipsl_stats.F90 $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    3335CONTAINS
    3436      SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl &
    35                   ,pnorm,pmol,refl,land,pplay,undef,ok_lidar_cfad &
    36                   ,cfad2,srbval &
    37                   ,ncat,lidarcld,cldlayer,parasolrefl)
     37                  ,tmp,pnorm,pnorm_perp,pmol,refl,land,pplay,undef,ok_lidar_cfad &
     38                  ,cfad2,srbval,ncat,lidarcld,lidarcldphase,cldlayer,cldlayerphase &
     39                  ,lidarcldtmp,parasolrefl)
    3840!
    3941! -----------------------------------------------------------------------------------
    4042! Lidar outputs :
    4143!
    42 ! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction
    43 ! from the lidar signals (ATB and molecular ATB) computed from model outputs
     44! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction)
     45! and phase cloud fraction (3D, low/mid/high/total and 3D temperature)
     46! from the lidar signals (ATB, ATBperp and molecular ATB) computed from model outputs
    4447!      +
    4548! Compute CFADs of lidar scattering ratio SR and of depolarization index
    … …  
    6063! Optimisation of COSP_CFAD_SR
    6164!
    62 ! Version 1.0 (June 2007)
    63 ! Version 1.1 (May 2008)
    64 ! Version 1.2 (June 2008)
    65 ! Version 2.0 (October 2008)
    66 ! Version 2.1 (December 2008)
    67 ! c------------------------------------------------------------------------------------
     65! January 2013, G. Cesana, H. Chepfer:
     66! - Add the perpendicular component of the backscattered signal (pnorm_perp) in the arguments
     67! - Add the temperature (tmp) in the arguments
     68! - Add the 3D Phase cloud fraction (lidarcldphase) in the arguments
     69! - Add the Phase low mid high cloud fraction (cldlayerphase) in the arguments
     70! - Add the 3D Phase cloud fraction as a function of temperature (lidarcldtmp) in the arguments
     71! - Modification of the phase diagnosis within the COSP_CLDFRAC routine to integrate the phase
     72!   diagnosis (3D, low/mid/high, 3D temperature)
     73! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
     74! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
     75!
     76! ------------------------------------------------------------------------------------
    6877
    6978! c inputs :
    … …  
    8291      logical ok_lidar_cfad         ! true if lidar CFAD diagnostics need to be computed
    8392      real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol
     93      real tmp(npoints,llm)         ! temp at each levels
     94      real pnorm_perp(npoints,ncol,llm)  ! lidar perpendicular ATB
    8495
    8596! c outputs :
    8697      real lidarcld(npoints,llm)     ! 3D "lidar" cloud fraction
    87       real cldlayer(npoints,ncat)    ! "lidar" cloud fraction (low, mid, high, total)
     98      real sub(npoints,llm)     ! 3D "lidar" indice
     99      real cldlayer(npoints,ncat)    ! "lidar" cloud layer fraction (low, mid, high, total)
     100
    88101      real cfad2(npoints,max_bin,llm) ! CFADs of SR
    89102      real srbval(max_bin)           ! SR bins in CFADs
    … …  
    94107      parameter (S_clr = 1.2)
    95108      real S_cld
    96 !      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
    97       parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
     109      parameter (S_cld = 5.)  ! Thresold for cloud detection
    98110      real S_att
    99111      parameter (S_att = 0.01)
    100112
    101113! c local variables :
    102       integer ic,k
     114      integer ic,k,i,j
    103115      real x3d(npoints,ncol,llm)
    104116      real x3d_c(npoints,llm),pnorm_c(npoints,llm)
    105117      real xmax
     118
     119! Output variables
     120      integer,parameter :: nphase = 6 ! nb of cloud layer phase types (ice,liquid,undefined,false ice,false liquid,Percent of ice)
     121      real lidarcldphase(npoints,llm,nphase)   ! 3D "lidar" phase cloud fraction
     122      real lidarcldtmp(npoints,40,5)          ! 3D "lidar" phase cloud fraction as a function of temp
     123      real cldlayerphase(npoints,ncat,nphase)  ! "lidar" phase low mid high cloud fraction
     124
     125! SR detection threshold
     126      real, parameter  ::  S_cld_att = 30. ! New threshold for undefine cloud phase detection   
     127
     128
    106129!
    107130! c -------------------------------------------------------
    … …  
    109132! c -------------------------------------------------------
    110133!
    111 
    112134!  Should be modified in future version
    113135      xmax=undef-1.0
    … …  
    116138! c 1- Lidar scattering ratio :
    117139! c -------------------------------------------------------
    118 !
    119 !       where ((pnorm.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 ))
    120 !          x3d = pnorm/pmol
    121 !       elsewhere
    122 !           x3d = undef
    123 !       end where
    124 ! A.B-S: pmol reduced to 2D (npoints,llm) (Dec 08)
     140
    125141      do ic = 1, ncol
    126142        pnorm_c = pnorm(:,ic,:)
    … …  
    130146            x3d_c = undef
    131147        end where
    132         x3d(:,ic,:) = x3d_c
     148         x3d(:,ic,:) = x3d_c
    133149      enddo
    134150
    … …  
    138154! c -------------------------------------------------------
    139155
    140       CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,  &
    141               x3d,pplay, S_att,S_cld,undef,lidarcld, &
    142               cldlayer)
     156    CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase,  &
     157              tmp,x3d,pnorm,pnorm_perp,pplay, S_att,S_cld,S_cld_att,undef,lidarcld, &
     158              cldlayer,lidarcldphase,sub,cldlayerphase,lidarcldtmp)
    143159
    144160! c -------------------------------------------------------
    … …  
    242258! c c- Compute CFAD
    243259! c -------------------------------------------------------
    244 
    245260      do j = 1, Nlevels
    246261         do ib = 1, Nbins
    … …  
    264279      END SUBROUTINE COSP_CFAD_SR
    265280
     281
    266282!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    267283!-------------------- SUBROUTINE COSP_CLDFRAC -------------------
    268284! c Purpose: Cloud fraction diagnosed from lidar measurements
    269285!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    270       SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat, &
    271                   x,pplay,S_att,S_cld,undef,lidarcld, &
    272                   cldlayer)
     286      SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase, &
     287                  tmp,x,ATB,ATBperp,pplay,S_att,S_cld,S_cld_att,undef,lidarcld, &
     288                  cldlayer,lidarcldphase,nsub,cldlayerphase,lidarcldtemp)
     289
     290
    273291      IMPLICIT NONE
    274292! Input arguments
    275293      integer Npoints,Ncolumns,Nlevels,Ncat
    276294      real x(Npoints,Ncolumns,Nlevels)
     295
     296
     297! Local parameters
     298      integer nphase ! nb of cloud layer phase types
     299                                      ! (ice,liquid,undefined,false ice,false liquid,Percent of ice)
     300      integer,parameter  ::  Ntemp=40 ! indice of the temperature vector
     301      integer ip, k, iz, ic, ncol, nlev, i, itemp  ! loop indice
     302      real  S_cld_att ! New threshold for undefine cloud phase detection (SR=30)       
     303      integer toplvlsat  ! level of the first cloud with SR>30
     304      real alpha50, beta50, gamma50, delta50, epsilon50, zeta50 ! Polynomial Coef of the phase
     305                                                                ! discrimination line   
     306
     307! Input variables
     308      real tmp(Npoints,Nlevels)                 ! temperature
     309      real ATB(Npoints,Ncolumns,Nlevels) ! 3D Attenuated backscatter
     310      real ATBperp(Npoints,Ncolumns,Nlevels) ! 3D perpendicular attenuated backscatter
    277311      real pplay(Npoints,Nlevels)
    278312      real S_att,S_cld
    279313      real undef
    280 ! Output :
     314
     315! Output variables
     316      real lidarcldtemp(Npoints,Ntemp,5) ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq
     317      real tempmod(Ntemp+1)     ! temperature bins
     318      real lidarcldphase(Npoints,Nlevels,Nphase)    ! 3D cloud phase fraction
     319      real cldlayerphase(Npoints,Ncat,Nphase) ! low, middle, high, total cloud fractions for ice liquid and undefine phase
    281320      real lidarcld(Npoints,Nlevels) ! 3D cloud fraction
    282321      real cldlayer(Npoints,Ncat)    ! low, middle, high, total cloud fractions
     322
    283323! Local variables
    284       integer ip, k, iz, ic
     324      real tmpi(Npoints,Ncolumns,Nlevels)       ! temperature of ice cld
     325      real tmpl(Npoints,Ncolumns,Nlevels)       ! temperature of liquid cld
     326      real tmpu(Npoints,Ncolumns,Nlevels)       ! temperature of undef cld
     327
     328      real checktemp, ATBperp_tmp ! temporary variable
     329      real checkcldlayerphase, checkcldlayerphase2 ! temporary variable
     330      real sumlidarcldtemp(Npoints,Ntemp) ! temporary variable
     331
     332      real cldlayphase(Npoints,Ncolumns,Ncat,Nphase) ! subgrided low mid high phase cloud fraction
     333      real cldlayerphasetmp(Npoints,Ncat) ! temporary variable
     334      real cldlayerphasesum(Npoints,Ncat) ! temporary variable
     335      real lidarcldtempind(Npoints,Ntemp) ! 3D Temperature indice
     336      real lidarcldphasetmp(Npoints,Nlevels)  ! 3D sum of ice and liquid cloud occurences
     337
     338
     339! Local variables
    285340      real p1
    286341      real cldy(Npoints,Ncolumns,Nlevels)
    … …  
    290345      real nsub(Npoints,Nlevels)
    291346
     347#ifdef SYS_SX
    292348      real cldlay1(Npoints,Ncolumns)
    293349      real cldlay2(Npoints,Ncolumns)
    … …  
    296352      real nsublay2(Npoints,Ncolumns)
    297353      real nsublay3(Npoints,Ncolumns)
     354#endif
     355
     356
    298357
    299358
    … …  
    311370      cldlay = 0.0
    312371      nsublay = 0.0
     372
     373      ATBperp_tmp = 0.
     374      lidarcldphase(:,:,:) = 0.
     375      cldlayphase(:,:,:,:) = 0.
     376      cldlayerphase(:,:,:) = 0.
     377      tmpi(:,:,:) = 0.
     378      tmpl(:,:,:) = 0.
     379      tmpu(:,:,:) = 0.
     380      cldlayerphasesum(:,:) = 0.
     381      lidarcldtemp(:,:,:) = 0.
     382      lidarcldtempind(:,:) = 0.
     383      sumlidarcldtemp(:,:) = 0.
     384      toplvlsat=0
     385      lidarcldphasetmp(:,:) = 0.
     386
     387! temperature bins
     388      tempmod=(/-273.15,-90.,-87.,-84.,-81.,-78.,-75.,-72.,-69.,-66.,-63.,-60.,-57., &
     389                -54.,-51.,-48.,-45.,-42.,-39.,-36.,-33.,-30.,-27.,-24.,-21.,-18.,  &
     390                -15.,-12.,-9.,-6.,-3.,0.,3.,6.,9.,12.,15.,18.,21.,24.,200. /)
     391       
     392! convert C to K
     393      tempmod=tempmod+273.15
     394
     395! Polynomial coefficient of the phase discrimination line used to separate liquid from ice
     396! (Cesana and Chepfer, JGR, 2013)
     397! ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 + ATB*epsilon50 + zeta50
     398      alpha50   = 9.0322e+15
     399      beta50    = -2.1358e+12
     400      gamma50   = 173.3963e06
     401      delta50   = -3.9514e03
     402      epsilon50 = 0.2559
     403      zeta50    = -9.4776e-07
     404
    313405
    314406! ---------------------------------------------------------------
    … …  
    334426      enddo ! k
    335427
     428
    336429! ---------------------------------------------------------------
    337430! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure
    … …  
    340433      lidarcld = 0.0
    341434      nsub = 0.0
    342 
     435#ifdef SYS_SX
    343436!! XXX: Use cldlay[1-3] and nsublay[1-3] to avoid bank-conflicts.
    344437      cldlay1 = 0.0
    … …  
    350443      nsublay3 = 0.0
    351444      nsublay(:,:,4) = 0.0
     445
    352446      do k = Nlevels, 1, -1
    353447       do ic = 1, Ncolumns
    354448        do ip = 1, Npoints
     449
     450         if(srok(ip,ic,k).gt.0.)then
     451           ! Computation of the cloud fraction as a function of the temperature
     452           ! instead of height, for ice,liquid and all clouds
     453           do itemp=1,Ntemp
     454             if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
     455               lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1.
     456             endif
     457           enddo
     458         endif
     459
     460         if (cldy(ip,ic,k).eq.1.) then
     461           do itemp=1,Ntemp
     462             if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
     463               lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1.
     464             endif
     465           enddo
     466         endif
     467
    355468         p1 = pplay(ip,k)
    356469
    … …  
    379492      nsublay(:,:,2) = nsublay2
    380493      nsublay(:,:,3) = nsublay3
     494#else
     495      cldlay = 0.0
     496      nsublay = 0.0
     497      do k = Nlevels, 1, -1
     498       do ic = 1, Ncolumns
     499        do ip = 1, Npoints
     500
     501          ! Computation of the cloud fraction as a function of the temperature
     502          ! instead of height, for ice,liquid and all clouds
     503          if(srok(ip,ic,k).gt.0.)then
     504          do itemp=1,Ntemp
     505            if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
     506              lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1.
     507            endif
     508          enddo
     509          endif
     510
     511          if(cldy(ip,ic,k).eq.1.)then
     512          do itemp=1,Ntemp
     513            if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
     514              lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1.
     515            endif
     516          enddo
     517          endif
     518!
     519
     520          iz=1
     521          p1 = pplay(ip,k)
     522          if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds
     523            iz=3
     524          else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then  ! mid clouds
     525            iz=2
     526         endif
     527
     528         cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
     529         cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
     530         lidarcld(ip,k)=lidarcld(ip,k) + cldy(ip,ic,k)
     531
     532         nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
     533         nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
     534         nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k)
     535
     536        enddo
     537       enddo
     538      enddo
     539#endif
     540
    381541
    382542! -- grid-box 3D cloud fraction
    … …  
    407567      endwhere
    408568
    409       RETURN
     569! ---------------------------------------------------------------
     570! 4- grid-box 3D cloud Phase :
     571! ---------------------------------------------------------------
     572! ---------------------------------------------------------------
     573! 4.1 - For Cloudy pixels with 8.16km < z < 19.2km
     574! ---------------------------------------------------------------
     575do ncol=1,Ncolumns
     576do i=1,Npoints
     577
     578      do nlev=Nlevels,18,-1  ! from 19.2km until 8.16km
     579         p1 = pplay(i,nlev)
     580
     581
     582! Avoid zero values
     583        if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then
     584! Computation of the ATBperp along the phase discrimination line
     585           ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
     586                         (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
     587                          ATB(i,ncol,nlev)*epsilon50 + zeta50
     588
     589!____________________________________________________________________________________________________
     590!
     591!4.1.a Ice: ATBperp above the phase discrimination line
     592!____________________________________________________________________________________________________
     593!
     594           if( (ATBperp(i,ncol,nlev)-ATBperp_tmp).ge.0. )then   ! Ice clouds
     595             ! ICE with temperature above 273,15°K = Liquid (false ice)
     596            if(tmp(i,nlev).gt.273.15)then                ! Temperature above 273,15 K
     597              ! Liquid: False ice corrected by the temperature to Liquid
     598               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.   ! false ice detection ==> added to Liquid
     599               tmpl(i,ncol,nlev)=tmp(i,nlev)
     600               lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1.   ! keep the information "temperature criterium used"
     601                                                    ! to classify the phase cloud
     602                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
     603                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     604                   cldlayphase(i,ncol,3,2) = 1.
     605                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     606                   cldlayphase(i,ncol,2,2) = 1.
     607                else                                                    ! low cloud
     608                   cldlayphase(i,ncol,1,2) = 1.
     609                endif
     610                   cldlayphase(i,ncol,4,5) = 1.                         ! tot cloud
     611                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     612                   cldlayphase(i,ncol,3,5) = 1.
     613                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     614                   cldlayphase(i,ncol,2,5) = 1.
     615                else                                                    ! low cloud
     616                   cldlayphase(i,ncol,1,5) = 1.
     617                endif
     618
     619             else
     620             ! ICE with temperature below 273,15°K
     621              lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.
     622              tmpi(i,ncol,nlev)=tmp(i,nlev)
     623                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
     624                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     625                   cldlayphase(i,ncol,3,1) = 1.
     626                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     627                   cldlayphase(i,ncol,2,1) = 1.
     628                else                                                    ! low cloud
     629                   cldlayphase(i,ncol,1,1) = 1.
     630                endif
     631
     632              endif
     633
     634!____________________________________________________________________________________________________
     635!
     636! 4.1.b Liquid: ATBperp below the phase discrimination line
     637!____________________________________________________________________________________________________
     638!
     639             else                                        ! Liquid clouds
     640              ! Liquid with temperature above 231,15°K
     641            if(tmp(i,nlev).gt.231.15)then
     642               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.
     643               tmpl(i,ncol,nlev)=tmp(i,nlev)
     644                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
     645                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     646                   cldlayphase(i,ncol,3,2) = 1. 
     647                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     648                   cldlayphase(i,ncol,2,2) = 1.
     649                else                                                    ! low cloud
     650                   cldlayphase(i,ncol,1,2) = 1.
     651                endif
     652
     653             else
     654             ! Liquid with temperature below 231,15°K = Ice (false liquid)
     655               tmpi(i,ncol,nlev)=tmp(i,nlev)
     656               lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.   ! false liquid detection ==> added to ice
     657               lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1.   ! keep the information "temperature criterium used"
     658                                                    ! to classify the phase cloud
     659                   cldlayphase(i,ncol,4,4) = 1.                         ! tot cloud
     660                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     661                   cldlayphase(i,ncol,3,4) = 1. 
     662                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     663                   cldlayphase(i,ncol,2,4) = 1.
     664                else                                                    ! low cloud
     665                   cldlayphase(i,ncol,1,4) = 1.
     666                endif
     667                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
     668                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     669                   cldlayphase(i,ncol,3,1) = 1. 
     670                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     671                   cldlayphase(i,ncol,2,1) = 1.
     672                else                                                    ! low cloud
     673                   cldlayphase(i,ncol,1,1) = 1.
     674                endif
     675
     676             endif
     677
     678            endif  ! end of discrimination condition
     679         endif  ! end of cloud condition
     680      enddo ! end of altitude loop
     681
     682
     683
     684! ---------------------------------------------------------------
     685! 4.2 - For Cloudy pixels with 0km < z < 8.16km
     686! ---------------------------------------------------------------
     687
     688      toplvlsat=0
     689      do nlev=17,1,-1  ! from 8.16km until 0km
     690         p1 = pplay(i,nlev)
     691
     692        if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then
     693! Phase discrimination line : ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50
     694!                                  + ATB*epsilon50 + zeta50
     695! Computation of the ATBperp of the phase discrimination line
     696           ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
     697                         (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
     698                          ATB(i,ncol,nlev)*epsilon50 + zeta50
     699!____________________________________________________________________________________________________
     700!
     701! 4.2.a Ice: ATBperp above the phase discrimination line
     702!____________________________________________________________________________________________________
     703!
     704            ! ICE with temperature above 273,15°K = Liquid (false ice)
     705          if( (ATBperp(i,ncol,nlev)-ATBperp_tmp).ge.0. )then   ! Ice clouds
     706            if(tmp(i,nlev).gt.273.15)then
     707               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.  ! false ice ==> liq
     708               tmpl(i,ncol,nlev)=tmp(i,nlev)
     709               lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1.
     710
     711                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
     712               if ( p1.gt.0. .and. p1.lt.(440.*100.)) then              ! high cloud
     713                   cldlayphase(i,ncol,3,2) = 1.
     714                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     715                   cldlayphase(i,ncol,2,2) = 1.
     716                else                                                    ! low cloud
     717                   cldlayphase(i,ncol,1,2) = 1.
     718                endif
     719
     720                   cldlayphase(i,ncol,4,5) = 1.                         ! tot cloud
     721                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     722                   cldlayphase(i,ncol,3,5) = 1.
     723                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     724                   cldlayphase(i,ncol,2,5) = 1.
     725                else                                                    ! low cloud
     726                   cldlayphase(i,ncol,1,5) = 1.
     727                endif
     728
     729             else
     730              ! ICE with temperature below 273,15°K
     731              lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.
     732              tmpi(i,ncol,nlev)=tmp(i,nlev)
     733
     734                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
     735                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     736                   cldlayphase(i,ncol,3,1) = 1.
     737                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     738                   cldlayphase(i,ncol,2,1) = 1.
     739                else                                                    ! low cloud
     740                   cldlayphase(i,ncol,1,1) = 1.
     741                endif
     742
     743              endif
     744
     745!____________________________________________________________________________________________________
     746!
     747! 4.2.b Liquid: ATBperp below the phase discrimination line
     748!____________________________________________________________________________________________________
     749!
     750          else 
     751             ! Liquid with temperature above 231,15°K
     752            if(tmp(i,nlev).gt.231.15)then
     753               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.
     754               tmpl(i,ncol,nlev)=tmp(i,nlev)
     755
     756                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
     757                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     758                   cldlayphase(i,ncol,3,2) = 1. 
     759                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     760                   cldlayphase(i,ncol,2,2) = 1.
     761                else                                                    ! low cloud
     762                   cldlayphase(i,ncol,1,2) = 1.
     763                endif
     764
     765             else
     766             ! Liquid with temperature below 231,15°K = Ice (false liquid)
     767               tmpi(i,ncol,nlev)=tmp(i,nlev)
     768               lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.  ! false liq ==> ice
     769               lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1.  ! false liq ==> ice
     770
     771                   cldlayphase(i,ncol,4,4) = 1.                         ! tot cloud
     772                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     773                   cldlayphase(i,ncol,3,4) = 1. 
     774                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     775                   cldlayphase(i,ncol,2,4) = 1.
     776                else                                                    ! low cloud
     777                   cldlayphase(i,ncol,1,4) = 1.
     778                endif
     779
     780                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
     781                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
     782                   cldlayphase(i,ncol,3,1) = 1. 
     783                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
     784                   cldlayphase(i,ncol,2,1) = 1.
     785                else                                                    ! low cloud
     786                   cldlayphase(i,ncol,1,1) = 1.
     787                endif
     788
     789             endif
     790           endif  ! end of discrimination condition
     791
     792            toplvlsat=0
     793
     794           ! Find the level of the highest cloud with SR>30
     795            if(x(i,ncol,nlev).gt.S_cld_att)then  ! SR > 30.
     796                toplvlsat=nlev-1
     797                goto 99
     798            endif
     799
     800        endif  ! end of cloud condition
     801       enddo  ! end of altitude loop
     802
     80399 continue
     804
     805!____________________________________________________________________________________________________
     806!
     807! Undefined phase: For a cloud located below another cloud with SR>30
     808! see Cesana and Chepfer 2013 Sect.III.2
     809!____________________________________________________________________________________________________
     810!
     811if(toplvlsat.ne.0)then         
     812      do nlev=toplvlsat,1,-1
     813         p1 = pplay(i,nlev)
     814        if(cldy(i,ncol,nlev).eq.1.)then
     815           lidarcldphase(i,nlev,3)=lidarcldphase(i,nlev,3)+1.
     816           tmpu(i,ncol,nlev)=tmp(i,nlev)
     817
     818                   cldlayphase(i,ncol,4,3) = 1.                         ! tot cloud
     819          if ( p1.gt.0. .and. p1.lt.(440.*100.)) then              ! high cloud
     820             cldlayphase(i,ncol,3,3) = 1.
     821          else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then  ! mid cloud
     822             cldlayphase(i,ncol,2,3) = 1.
     823          else                                                     ! low cloud
     824             cldlayphase(i,ncol,1,3) = 1.
     825          endif
     826
     827        endif   
     828      enddo
     829endif
     830     
     831      toplvlsat=0
     832
     833enddo
     834enddo
     835
     836
     837
     838!____________________________________________________________________________________________________
     839!
     840! Computation of final cloud phase diagnosis
     841!____________________________________________________________________________________________________
     842!
     843
     844! Compute the Ice percentage in cloud = ice/(ice+liq) as a function
     845! of the occurrences
     846lidarcldphasetmp(:,:)=lidarcldphase(:,:,1)+lidarcldphase(:,:,2);
     847WHERE (lidarcldphasetmp(:,:).gt. 0.)
     848   lidarcldphase(:,:,6)=lidarcldphase(:,:,1)/lidarcldphasetmp(:,:)
     849ELSEWHERE
     850   lidarcldphase(:,:,6) = undef
     851ENDWHERE
     852
     853! Compute Phase 3D Cloud Fraction
     854     WHERE ( nsub(:,:).gt.0.0 )
     855       lidarcldphase(:,:,1)=lidarcldphase(:,:,1)/nsub(:,:)
     856       lidarcldphase(:,:,2)=lidarcldphase(:,:,2)/nsub(:,:)
     857       lidarcldphase(:,:,3)=lidarcldphase(:,:,3)/nsub(:,:)
     858       lidarcldphase(:,:,4)=lidarcldphase(:,:,4)/nsub(:,:)
     859       lidarcldphase(:,:,5)=lidarcldphase(:,:,5)/nsub(:,:)
     860     ELSEWHERE
     861       lidarcldphase(:,:,1) = undef
     862       lidarcldphase(:,:,2) = undef
     863       lidarcldphase(:,:,3) = undef
     864       lidarcldphase(:,:,4) = undef
     865       lidarcldphase(:,:,5) = undef
     866     ENDWHERE
     867
     868
     869! Compute Phase low mid high cloud fractions
     870    do iz = 1, Ncat
     871       do i=1,Nphase-3
     872       do ic = 1, Ncolumns
     873          cldlayerphase(:,iz,i)=cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i)
     874          cldlayerphasesum(:,iz)=cldlayerphasesum(:,iz)+cldlayphase(:,ic,iz,i)
     875       enddo
     876      enddo
     877    enddo
     878
     879    do iz = 1, Ncat
     880       do i=4,5
     881       do ic = 1, Ncolumns
     882          cldlayerphase(:,iz,i)=cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i)         
     883       enddo
     884       enddo
     885    enddo
     886   
     887! Compute the Ice percentage in cloud = ice/(ice+liq)
     888cldlayerphasetmp(:,:)=cldlayerphase(:,:,1)+cldlayerphase(:,:,2)
     889    WHERE (cldlayerphasetmp(:,:).gt. 0.)
     890       cldlayerphase(:,:,6)=cldlayerphase(:,:,1)/cldlayerphasetmp(:,:)
     891    ELSEWHERE
     892       cldlayerphase(:,:,6) = undef
     893    ENDWHERE
     894
     895    do i=1,Nphase-1
     896      WHERE ( cldlayerphasesum(:,:).gt.0.0 )
     897         cldlayerphase(:,:,i) = (cldlayerphase(:,:,i)/cldlayerphasesum(:,:)) * cldlayer(:,:)
     898      ENDWHERE
     899    enddo
     900
     901
     902    do i=1,Npoints
     903       do iz=1,Ncat
     904          checkcldlayerphase=0.
     905          checkcldlayerphase2=0.
     906
     907          if (cldlayerphasesum(i,iz).gt.0.0 )then
     908             do ic=1,Nphase-3
     909                checkcldlayerphase=checkcldlayerphase+cldlayerphase(i,iz,ic) 
     910             enddo
     911             checkcldlayerphase2=cldlayer(i,iz)-checkcldlayerphase
     912             if( (checkcldlayerphase2.gt.0.01).or.(checkcldlayerphase2.lt.-0.01) ) print *, checkcldlayerphase,cldlayer(i,iz)
     913
     914          endif
     915
     916       enddo
     917    enddo
     918
     919    do i=1,Nphase-1
     920      WHERE ( nsublayer(:,:).eq.0.0 )
     921         cldlayerphase(:,:,i) = undef
     922      ENDWHERE
     923   enddo
     924
     925
     926
     927! Compute Phase 3D as a function of temperature
     928do nlev=1,Nlevels
     929do ncol=1,Ncolumns     
     930do i=1,Npoints
     931do itemp=1,Ntemp
     932if(tmpi(i,ncol,nlev).gt.0.)then
     933      if( (tmpi(i,ncol,nlev).ge.tempmod(itemp)).and.(tmpi(i,ncol,nlev).lt.tempmod(itemp+1)) )then
     934        lidarcldtemp(i,itemp,2)=lidarcldtemp(i,itemp,2)+1.
     935      endif
     936elseif(tmpl(i,ncol,nlev).gt.0.)then
     937      if( (tmpl(i,ncol,nlev).ge.tempmod(itemp)).and.(tmpl(i,ncol,nlev).lt.tempmod(itemp+1)) )then
     938        lidarcldtemp(i,itemp,3)=lidarcldtemp(i,itemp,3)+1.
     939      endif
     940elseif(tmpu(i,ncol,nlev).gt.0.)then
     941      if( (tmpu(i,ncol,nlev).ge.tempmod(itemp)).and.(tmpu(i,ncol,nlev).lt.tempmod(itemp+1)) )then
     942        lidarcldtemp(i,itemp,4)=lidarcldtemp(i,itemp,4)+1.
     943      endif
     944endif
     945enddo
     946enddo
     947enddo
     948enddo
     949
     950! Check temperature cloud fraction
     951do i=1,Npoints
     952   do itemp=1,Ntemp
     953checktemp=lidarcldtemp(i,itemp,2)+lidarcldtemp(i,itemp,3)+lidarcldtemp(i,itemp,4)
     954
     955        if(checktemp.NE.lidarcldtemp(i,itemp,1))then
     956          print *, i,itemp
     957          print *, lidarcldtemp(i,itemp,1:4)
     958        endif
     959
     960   enddo
     961enddo
     962
     963! Compute the Ice percentage in cloud = ice/(ice+liq)
     964!   sumlidarcldtemp=sum(lidarcldtemp(:,:,2:3),3)
     965   sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3)
     966
     967WHERE(sumlidarcldtemp(:,:)>0.)
     968  lidarcldtemp(:,:,5)=lidarcldtemp(:,:,2)/sumlidarcldtemp(:,:)
     969ELSEWHERE
     970  lidarcldtemp(:,:,5)=undef
     971ENDWHERE
     972
     973do i=1,4
     974  WHERE(lidarcldtempind(:,:).gt.0.)
     975     lidarcldtemp(:,:,i) = lidarcldtemp(:,:,i)/lidarcldtempind(:,:)
     976  ELSEWHERE
     977     lidarcldtemp(:,:,i) = undef
     978  ENDWHERE
     979enddo
     980
     981       RETURN
    410982      END SUBROUTINE COSP_CLDFRAC
    411983! ---------------------------------------------------------------
    412984
     985
    413986END MODULE MOD_LMD_IPSL_STATS

  • LMDZ5/branches/testing/libf/phylmd/cosp/math_lib.F90

    r2298 r2435  
     1! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/math_lib.f90 $
    13! MATH_LIB: Mathematics procedures for F90
    24! Compiled/Modified:
    … …  
    4244  integer :: k,m1,m
    4345       
    44   pi = acos(-1.)       
     46  pi = acos(-1.)   
    4547  if (x ==int(x)) then
    4648    if (x > 0.0) then

  • LMDZ5/branches/testing/libf/phylmd/cosp/optics_lib.F90

    r2298 r2435  
     1! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/optics_lib.f90 $
    13! OPTICS_LIB: Optical proecures for for F90
    24! Compiled/Modified:
    … …  
    1517! subroutine M_WAT
    1618! ----------------------------------------------------------------------------
    17   subroutine m_wat(freq, t, n_r, n_i)
     19  subroutine m_wat(freq, tk, n_r, n_i)
    1820  implicit none
    1921! 
    … …  
    2325! Inputs:
    2426!   [freq]    frequency (GHz)
    25 !   [t]       temperature (C)
     27!   [tk]       temperature (K)
    2628!
    2729! Outputs:
    … …  
    3638 
    3739! ----- INPUTS -----
    38   real*8, intent(in) :: freq,t
     40  real*8, intent(in) :: freq,tk
    3941 
    4042! ----- OUTPUTS -----
    … …  
    4547  real*8 e_r,e_i
    4648  real*8 pi
     49  real*8 tc
    4750  complex*16 e_comp, sq
    4851
     52  tc = tk - 273.15
     53
    4954  ld = 100.*2.99792458E8/(freq*1E9)
    50   es = 78.54*(1-(4.579E-3*(t-25.)+1.19E-5*(t-25.)**2 &
    51        -2.8E-8*(t-25.)**3))
    52   ei = 5.27137+0.021647*t-0.00131198*t**2
    53   a = -(16.8129/(t+273.))+0.0609265
    54   ls = 0.00033836*exp(2513.98/(t+273.))
     55  es = 78.54*(1-(4.579E-3*(tc-25.)+1.19E-5*(tc-25.)**2 &
     56       -2.8E-8*(tc-25.)**3))
     57  ei = 5.27137+0.021647*tc-0.00131198*tc**2
     58  a = -(16.8129/(tc+273.))+0.0609265
     59  ls = 0.00033836*exp(2513.98/(tc+273.))
    5560  sg = 12.5664E8
    5661
    … …  
    8489! Inputs:
    8590!   [freq]    frequency (GHz)
    86 !   [t]       temperature (C)
     91!   [t]       temperature (K)
    8792!
    8893! Outputs:
    … …  
    106111  parameter(nwl=468,nwlt=62)
    107112
    108   real*8 :: alam,cutice,pi,t1,t2,tk,wlmax,wlmin, &
    109             x,x1,x2,y,y1,y2,ylo,yhi
     113  real*8 :: alam,cutice,pi,t1,t2,wlmax,wlmin, &
     114            x,x1,x2,y,y1,y2,ylo,yhi,tk
    110115
    111116  real*8 :: &
    … …  
    502507  n_i=0.0
    503508
     509  tk = t
     510
    504511! // convert frequency to wavelength (um)
    505512  alam=3E5/freq
    … …  
    508515    stop
    509516  endif
    510 
    511 ! // convert temperature to K
    512   tk = t + 273.16
    513517
    514518  if (alam < cutice) then
    … …  
    706710         Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
    707711         If (N.Gt.1) then
    708             Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
     712         Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
    709713         End If
    710714         Anm1 = A

  • LMDZ5/branches/testing/libf/phylmd/cosp/pf_to_mr.F

    r2298 r2435  
    11! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
    22! All rights reserved.
     3! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/pf_to_mr.f $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    3537      INTEGER ncol          !  number of subcolumns
    3638
    37       INTEGER i,j,ilev,ibox
     39      INTEGER j,ilev,ibox
    3840     
    39       REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precipitation flux
     41      REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precip. flux
    4042      REAL grpl_ls(npoints,nlev)
    41       REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precipitation flux
     43      REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precip. flux
    4244
    4345      REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
    … …  
    5456      REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g
    5557     
    56       ! method from Khairoutdinov and Randall (2003 JAS)               
     58      ! method from Khairoutdinov and Randall (2003 JAS)
    5759
    5860      ! --- List of constants from Appendix B

  • LMDZ5/branches/testing/libf/phylmd/cosp/phys_cosp.F90

    r2408 r2435  
    22
    33! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS
    4 !Idelkadi Abderrahmane Aout-Septembre 2009
     4!Idelkadi Abderrahmane Aout-Septembre 2009 First Version
     5!Idelkadi Abderrahmane Nov 2015 version v1.4.0
    56
    67  subroutine phys_cosp( itap,dtime,freq_cosp, &
    … …  
    6768! meantbisccp,                          !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
    6869! meantbclrisccp                        !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
     70
     71!!! AI rajouter les nouvelles sorties
    6972!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    7073
     74!! AI rajouter
     75  #include "cosp_defs.h"
    7176  USE MOD_COSP_CONSTANTS
    7277  USE MOD_COSP_TYPES
    … …  
    7883  use cosp_output_mod
    7984  use cosp_output_write_mod
    80  
     85!  use MOD_COSP_Modis_Simulator, only : cosp_modis
     86
    8187  IMPLICIT NONE
    8288
    … …  
    100106  type(cosp_sglidar) :: sglidar ! Output from lidar simulator
    101107  type(cosp_isccp)   :: isccp   ! Output from ISCCP simulator
     108!! AI rajout modis
     109  type(cosp_modis)   :: modis   ! Output from MODIS simulator
     110!!
    102111  type(cosp_misr)    :: misr    ! Output from MISR simulator
     112!! AI rajout rttovs
     113!  type(cosp_rttov)   :: rttov   ! Output from RTTOV
     114!!
    103115  type(cosp_vgrid)   :: vgrid   ! Information on vertical grid of stats
    104116  type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator
    … …  
    106118
    107119  integer :: t0,t1,count_rate,count_max
    108   integer :: Nlon,Nlat,geomode
     120  integer :: Nlon,Nlat
    109121  real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw
    110122!$OMP THREADPRIVATE(emsfc_lw)
    … …  
    134146  integer                         :: itap,k,ip
    135147  real                            :: dtime,freq_cosp
     148  real,dimension(2)               :: time_bnds
    136149 
    137 !
    138150   namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, &
    139151              npoints_it,ncolumns,use_vgrid,nlr,csat_vgrid, &
    … …  
    167179
    168180  print*,' Cles des differents simulateurs cosp :'
    169   print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', &
    170           cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim
     181  print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim', &
     182          cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim,cfg%Lrttov_sim
    171183
    172184  endif ! debut_cosp
     185
     186  time_bnds(1) = dtime-dtime/2.
     187  time_bnds(2) = dtime+dtime/2.
    173188
    174189!  print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', &
    … …  
    178193!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    179194        print *, 'Allocating memory for gridbox type...'
    180 
    181         call construct_cosp_gridbox(dble(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
     195!! AI
     196!        call construct_cosp_gridbox(dble(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
     197!                                    Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
     198!                                    lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, &
     199!                                    use_precipitation_fluxes,use_reff, &
     200!                                    Platform,Satellite,Instrument,Nchannels,ZenAng, &
     201!                                    channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx)
     202! Surafce emissivity
     203        emsfc_lw = 1.
     204
     205        call construct_cosp_gridbox(dtime,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, &
     206                                    do_ray,melt_lay,k2, &
    182207                                    Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
    183208                                    lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, &
    … …  
    230255
    231256! sunlit calcule a partir de la fraction d ensoleillement par jour
    232       do ip = 1, Npoints
    233         if (sunlit(ip).le.0.) then
    234            gbx%sunlit(ip)=0.
    235         else
    236            gbx%sunlit(ip)=1.
    237         endif
    238       enddo
     257!      do ip = 1, Npoints
     258!        if (sunlit(ip).le.0.) then
     259!           gbx%sunlit(ip)=0.
     260!        else
     261!           gbx%sunlit(ip)=1.
     262!        endif
     263!      enddo
     264       gbx%sunlit=sunlit
    239265
    240266! A voir l equivalent LMDZ
    … …  
    260286     gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6
    261287     gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6
     288!! AI A revoir
    262289     gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6
    263290     gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6
    … …  
    269296        gbx%dem_c    = 0.
    270297
    271 ! Surafce emissivity
    272        emsfc_lw = 1.
    273                
    274298!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    275299        ! Define new vertical grid
    … …  
    288312        call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar)
    289313        call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp)
     314!! AI rajout
     315        call construct_cosp_modis(cfg,Npoints,modis)
     316!!
    290317        call construct_cosp_misr(cfg,Npoints,misr)
     318!        call construct_cosp_rttov(cfg,Npoints,Nchannels,rttov)
    291319
    292320!+++++++++++++ Open output files and define output files axis !+++++++++++++
    … …  
    306334!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    307335        print *, 'Calling simulator...'
    308         call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
     336!! AI
     337!        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
     338!#ifdef RTTOV
     339!        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
     340!#else
     341        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
     342!#endif
     343!!
     344
    309345!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    310346
    311347!!!!!!!!!!!!!!!!!! Ecreture des sorties Cosp !!!!!!!!!!!!!!r!!!!!!:!!!!!
     348
    312349       print *, 'Calling write output'
    313350        call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
    314                                cfg, gbx, vgrid, sglidar, stlidar, isccp)
     351                               cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, &
     352                               isccp, misr, modis)
    315353
    316354!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    … …  
    326364        call free_cosp_isccp(isccp)
    327365        call free_cosp_misr(misr)
     366!! AI
     367        call free_cosp_modis(modis)
     368!        call free_cosp_rttov(rttov)
     369!!
    328370        call free_cosp_vgrid(vgrid) 
    329371 

  • LMDZ5/branches/testing/libf/phylmd/cosp/prec_scops.F

    r2298 r2435  
    11! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
    22! All rights reserved.
     3! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     4! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/prec_scops.f $
    35!
    46! Redistribution and use in source and binary forms, with or without modification, are permitted
    … …  
    4547                                        ! 1 -> LS precipitation
    4648                                        ! 2 -> CONV precipitation
    47                                         ! 3 -> both
     49                    ! 3 -> both
    4850                                        !TOA to SURFACE!!!!!!!!!!!!!!!!!!
    49                                        
     51                   
    5052      INTEGER flag_ls, flag_cv
    5153      INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for
    … …  
    5658 
    5759      do ilev=1,nlev
    58       do ibox=1,ncol
    59         do j=1,npoints
    60         prec_frac(j,ibox,ilev) = 0
     60        do ibox=1,ncol
     61          do j=1,npoints
     62            prec_frac(j,ibox,ilev) = 0
     63          enddo
    6164        enddo
    62       enddo
    6365      enddo
    6466     
    6567      do j=1,npoints
    6668       do ibox=1,ncol
    67        frac_out_ls(j,ibox)=0
    68        frac_out_cv(j,ibox)=0
    69        flag_ls=0
    70        flag_cv=0
     69        frac_out_ls(j,ibox)=0
     70        frac_out_cv(j,ibox)=0
     71        flag_ls=0
     72        flag_cv=0
    7173        do ilev=1,nlev
    72         if (frac_out(j,ibox,ilev) .eq. 1) then
    73           flag_ls=1
    74         endif
    75         if (frac_out(j,ibox,ilev) .eq. 2) then
    76           flag_cv=1
    77         endif
    78         enddo !loop over nlev
    79         if (flag_ls .eq. 1) then
    80         frac_out_ls(j,ibox)=1
    81         endif
    82         if (flag_cv .eq. 1) then
    83         frac_out_cv(j,ibox)=1
    84         endif
     74          if (frac_out(j,ibox,ilev) .eq. 1) then
     75            flag_ls=1
     76          endif
     77          if (frac_out(j,ibox,ilev) .eq. 2) then
     78            flag_cv=1
     79          endif
     80        enddo !loop over nlev
     81        if (flag_ls .eq. 1) then
     82          frac_out_ls(j,ibox)=1
     83        endif
     84        if (flag_cv .eq. 1) then
     85          frac_out_cv(j,ibox)=1
     86        endif
    8587       enddo  ! loop over ncol
    8688      enddo ! loop over npoints
    … …  
    8991       do j=1,npoints
    9092        flag_ls=0
    91         flag_cv=0
    92        
     93        flag_cv=0
     94   
    9395        if (ls_p_rate(j,1) .gt. 0.) then
    94          do ibox=1,ncol ! possibility ONE
    95           if (frac_out(j,ibox,1) .eq. 1) then
    96            prec_frac(j,ibox,1) = 1
    97            flag_ls=1
    98           endif
    99         enddo ! loop over ncol
    100         if (flag_ls .eq. 0) then ! possibility THREE
    101           do ibox=1,ncol
    102            if (frac_out(j,ibox,2) .eq. 1) then
    103             prec_frac(j,ibox,1) = 1
    104             flag_ls=1
    105            endif
    106           enddo ! loop over ncol
    107         endif
    108         if (flag_ls .eq. 0) then ! possibility Four
    109           do ibox=1,ncol
    110            if (frac_out_ls(j,ibox) .eq. 1) then
    111             prec_frac(j,ibox,1) = 1
    112             flag_ls=1
    113            endif
    114           enddo ! loop over ncol
    115         endif
    116         if (flag_ls .eq. 0) then ! possibility Five
    117           do ibox=1,ncol
    118 !         prec_frac(j,1:ncol,1) = 1
    119           prec_frac(j,ibox,1) = 1
    120           enddo ! loop over ncol
    121          endif
    122         endif
     96            do ibox=1,ncol ! possibility ONE
     97                if (frac_out(j,ibox,1) .eq. 1) then
     98                    prec_frac(j,ibox,1) = 1
     99                    flag_ls=1
     100                endif
     101            enddo ! loop over ncol
     102            if (flag_ls .eq. 0) then ! possibility THREE
     103                do ibox=1,ncol
     104                    if (frac_out(j,ibox,2) .eq. 1) then
     105                        prec_frac(j,ibox,1) = 1
     106                        flag_ls=1
     107                    endif
     108                enddo ! loop over ncol
     109            endif
     110        if (flag_ls .eq. 0) then ! possibility Four
     111        do ibox=1,ncol
     112        if (frac_out_ls(j,ibox) .eq. 1) then
     113            prec_frac(j,ibox,1) = 1
     114            flag_ls=1
     115        endif
     116        enddo ! loop over ncol
     117        endif
     118        if (flag_ls .eq. 0) then ! possibility Five
     119        do ibox=1,ncol
     120    !     prec_frac(j,1:ncol,1) = 1
     121        prec_frac(j,ibox,1) = 1
     122        enddo ! loop over ncol
     123           endif
     124        endif
    123125       ! There is large scale precipitation
    124        
     126   
    125127        if (cv_p_rate(j,1) .gt. 0.) then
    126128         do ibox=1,ncol ! possibility ONE
    127129          if (frac_out(j,ibox,1) .eq. 2) then
    128130           if (prec_frac(j,ibox,1) .eq. 0) then
    129             prec_frac(j,ibox,1) = 2
    130            else
    131             prec_frac(j,ibox,1) = 3
    132            endif
    133            flag_cv=1
    134           endif
    135         enddo ! loop over ncol
    136         if (flag_cv .eq. 0) then ! possibility THREE
    137           do ibox=1,ncol
    138            if (frac_out(j,ibox,2) .eq. 2) then
    139             if (prec_frac(j,ibox,1) .eq. 0) then
    140              prec_frac(j,ibox,1) = 2
    141             else
    142              prec_frac(j,ibox,1) = 3
    143             endif
    144             flag_cv=1
    145            endif
    146           enddo ! loop over ncol
    147         endif
    148         if (flag_cv .eq. 0) then ! possibility Four
    149           do ibox=1,ncol
    150            if (frac_out_cv(j,ibox) .eq. 1) then
    151             if (prec_frac(j,ibox,1) .eq. 0) then
    152              prec_frac(j,ibox,1) = 2
    153             else
    154              prec_frac(j,ibox,1) = 3
    155             endif
    156             flag_cv=1
    157            endif
    158           enddo ! loop over ncol
    159         endif
    160         if (flag_cv .eq. 0) then  ! possibility Five
    161           do ibox=1,cv_col
    162             if (prec_frac(j,ibox,1) .eq. 0) then
    163              prec_frac(j,ibox,1) = 2
    164             else
    165              prec_frac(j,ibox,1) = 3
    166             endif
    167           enddo !loop over cv_col
    168          endif
    169         endif
    170        ! There is convective precipitation
    171        
    172        enddo ! loop over npoints
     131        prec_frac(j,ibox,1) = 2
     132       else
     133        prec_frac(j,ibox,1) = 3
     134       endif
     135       flag_cv=1
     136      endif
     137        enddo ! loop over ncol
     138        if (flag_cv .eq. 0) then ! possibility THREE
     139        do ibox=1,ncol
     140        if (frac_out(j,ibox,2) .eq. 2) then
     141                if (prec_frac(j,ibox,1) .eq. 0) then
     142            prec_frac(j,ibox,1) = 2
     143            else
     144            prec_frac(j,ibox,1) = 3
     145            endif
     146            flag_cv=1
     147        endif
     148        enddo ! loop over ncol
     149        endif
     150        if (flag_cv .eq. 0) then ! possibility Four
     151        do ibox=1,ncol
     152        if (frac_out_cv(j,ibox) .eq. 1) then
     153                if (prec_frac(j,ibox,1) .eq. 0) then
     154            prec_frac(j,ibox,1) = 2
     155            else
     156            prec_frac(j,ibox,1) = 3
     157            endif
     158            flag_cv=1
     159        endif
     160        enddo ! loop over ncol
     161        endif
     162        if (flag_cv .eq. 0) then  ! possibility Five
     163        do ibox=1,cv_col
     164                if (prec_frac(j,ibox,1) .eq. 0) then
     165            prec_frac(j,ibox,1) = 2
     166            else
     167            prec_frac(j,ibox,1) = 3
     168            endif
     169        enddo !loop over cv_col
     170           endif
     171        endif
     172        ! There is convective precipitation
     173       
     174        enddo ! loop over npoints
    173175!      end of initializing the top layer
    174176
    … …  
    179181       do j=1,npoints
    180182        flag_ls=0
    181         flag_cv=0
    182        
     183        flag_cv=0
     184   
    183185        if (ls_p_rate(j,ilev) .gt. 0.) then
    184186         do ibox=1,ncol ! possibility ONE&TWO
    … …  
    187189     &       .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
    188190           prec_frac(j,ibox,ilev) = 1
    189            flag_ls=1
     191           flag_ls=1
    190192          endif
    191         enddo ! loop over ncol
    192         if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
    193           do ibox=1,ncol
    194            if (frac_out(j,ibox,ilev+1) .eq. 1) then
    195             prec_frac(j,ibox,ilev) = 1
    196             flag_ls=1
    197            endif
    198           enddo ! loop over ncol
    199         endif
    200         if (flag_ls .eq. 0) then ! possibility Four
    201           do ibox=1,ncol
    202            if (frac_out_ls(j,ibox) .eq. 1) then
    203             prec_frac(j,ibox,ilev) = 1
    204             flag_ls=1
    205            endif
    206           enddo ! loop over ncol
    207         endif
    208         if (flag_ls .eq. 0) then ! possibility Five
    209           do ibox=1,ncol
    210 !         prec_frac(j,1:ncol,ilev) = 1
    211           prec_frac(j,ibox,ilev) = 1
    212           enddo ! loop over ncol
    213          endif
    214         endif ! There is large scale precipitation
    215        
     193        enddo ! loop over ncol
     194        if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
     195        do ibox=1,ncol
     196        if (frac_out(j,ibox,ilev+1) .eq. 1) then
     197            prec_frac(j,ibox,ilev) = 1
     198            flag_ls=1
     199        endif
     200        enddo ! loop over ncol
     201        endif
     202        if (flag_ls .eq. 0) then ! possibility Four
     203        do ibox=1,ncol
     204        if (frac_out_ls(j,ibox) .eq. 1) then
     205            prec_frac(j,ibox,ilev) = 1
     206            flag_ls=1
     207        endif
     208        enddo ! loop over ncol
     209        endif
     210        if (flag_ls .eq. 0) then ! possibility Five
     211        do ibox=1,ncol
     212!     prec_frac(j,1:ncol,ilev) = 1
     213        prec_frac(j,ibox,ilev) = 1
     214        enddo ! loop over ncol
     215         endif
     216      endif ! There is large scale precipitation
     217   
    216218        if (cv_p_rate(j,ilev) .gt. 0.) then
    217219         do ibox=1,ncol ! possibility ONE&TWO
    … …  
    220222     &       .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
    221223            if (prec_frac(j,ibox,ilev) .eq. 0) then
    222              prec_frac(j,ibox,ilev) = 2
    223             else
    224              prec_frac(j,ibox,ilev) = 3
    225             endif
    226            flag_cv=1
    227           endif
    228         enddo ! loop over ncol
    229         if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
    230           do ibox=1,ncol
    231            if (frac_out(j,ibox,ilev+1) .eq. 2) then
    232             if (prec_frac(j,ibox,ilev) .eq. 0) then
    233              prec_frac(j,ibox,ilev) = 2
    234             else
    235              prec_frac(j,ibox,ilev) = 3
    236             endif
    237             flag_cv=1
    238            endif
    239           enddo ! loop over ncol
    240         endif
    241         if (flag_cv .eq. 0) then ! possibility Four
    242           do ibox=1,ncol
    243            if (frac_out_cv(j,ibox) .eq. 1) then
    244             if (prec_frac(j,ibox,ilev) .eq. 0) then
    245              prec_frac(j,ibox,ilev) = 2
    246             else
    247              prec_frac(j,ibox,ilev) = 3
    248             endif
    249             flag_cv=1
    250            endif
    251           enddo ! loop over ncol
    252         endif
    253         if (flag_cv .eq. 0) then  ! possibility Five
    254           do ibox=1,cv_col
    255             if (prec_frac(j,ibox,ilev) .eq. 0) then
    256              prec_frac(j,ibox,ilev) = 2
    257             else
    258              prec_frac(j,ibox,ilev) = 3
    259             endif
    260           enddo !loop over cv_col
    261          endif
    262         endif ! There is convective precipitation
    263 
    264        enddo ! loop over npoints
    265       enddo ! loop over nlev
     224         prec_frac(j,ibox,ilev) = 2
     225        else
     226         prec_frac(j,ibox,ilev) = 3
     227        endif
     228        flag_cv=1
     229        endif
     230      enddo ! loop over ncol
     231        if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
     232        do ibox=1,ncol
     233        if (frac_out(j,ibox,ilev+1) .eq. 2) then
     234                if (prec_frac(j,ibox,ilev) .eq. 0) then
     235            prec_frac(j,ibox,ilev) = 2
     236            else
     237            prec_frac(j,ibox,ilev) = 3
     238            endif
     239            flag_cv=1
     240        endif
     241        enddo ! loop over ncol
     242        endif
     243        if (flag_cv .eq. 0) then ! possibility Four
     244        do ibox=1,ncol
     245        if (frac_out_cv(j,ibox) .eq. 1) then
     246                if (prec_frac(j,ibox,ilev) .eq. 0) then
     247            prec_frac(j,ibox,ilev) = 2
     248            else
     249            prec_frac(j,ibox,ilev) = 3
     250            endif
     251            flag_cv=1
     252        endif
     253        enddo ! loop over ncol
     254        endif
     255        if (flag_cv .eq. 0) then  ! possibility Five
     256        do ibox=1,cv_col
     257                if (prec_frac(j,ibox,ilev) .eq. 0) then
     258            prec_frac(j,ibox,ilev) = 2
     259            else
     260            prec_frac(j,ibox,ilev) = 3
     261            endif
     262        enddo !loop over cv_col
     263           endif
     264        endif ! There is convective precipitation
     265   
     266        enddo ! loop over npoints
     267        enddo ! loop over nlev
    266268
    267269      end

  • LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator.F90

    r2298 r2435  
    1   subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
    2     nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, &
    3     rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, &
     1  subroutine radar_simulator( &
     2    hp, &
     3    nprof,ngate, &
     4    undef, &
     5    hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
     6    p_matrix,t_matrix,rh_matrix, &
     7    Ze_non,Ze_ray,a_to_vol,g_to_vol,dBZe, &
    48    g_to_vol_in,g_to_vol_out)
    5 
    6 !     rh_matrix,Ze_non,Ze_ray,kr_matrix,g_atten_to_vol,dBZe)
    79 
    810  use m_mrgrnk
    … …  
    1113  use optics_lib
    1214  use radar_simulator_types
     15  use scale_LUTs_io
    1316  implicit none
    1417 
    1518! Purpose:
     19!
    1620!   Simulates a vertical profile of radar reflectivity
    17 !   Part of QuickBeam v1.04 by John Haynes & Roger Marchand
     21!   Originally Part of QuickBeam v1.04 by John Haynes & Roger Marchand.
     22!   but has been substantially modified since that time by
     23!   Laura Fowler and Roger Marchand (see modifications below).
    1824!
    1925! Inputs:
    20 !   [freq]            radar frequency (GHz), can be anything unless
    21 !                     use_mie_table=1, in which case one of 94,35,13.8,9.6,3
    22 !   [k2]              |K|^2, the dielectric constant, set to -1 to use the
    23 !                     frequency dependent default
    24 !   [do_ray]          1=do Rayleigh calcs, 0=not
    25 !   [use_gas_abs]     1=do gaseous abs calcs, 0=not,
    26 !                     2=use same as first profile (undocumented)
    27 !   [use_mie_table]   1=use Mie tables, 0=not
    28 !   [mt]              Mie look up table
    29 !   [nhclass]         number of hydrometeor types
    30 !   [hp]              structure that defines hydrometeor types
     26!
     27!   [hp]              structure that defines hydrometeor types and other radar properties
     28!
    3129!   [nprof]           number of hydrometeor profiles
    3230!   [ngate]           number of vertical layers
    33 !   [nsizes]          number of discrete particles in [D]
    34 !   [D]               array of discrete particles (um)
    35 !
     31!
     32!   [undef]           missing data value
    3633!   (The following 5 arrays must be in order from closest to the radar
    3734!    to farthest...)
     35!
    3836!   [hgt_matrix]      height of hydrometeors (km)
     37!   [p_matrix]        pressure profile (hPa)
     38!   [t_matrix]        temperature profile (K)
     39!   [rh_matrix]       relative humidity profile (%) -- only needed if gaseous aborption calculated.
     40!
    3941!   [hm_matrix]       table of hydrometeor mixing rations (g/kg)
    40 !   [re_matrix]       OPTIONAL table of hydrometeor effective radii (microns)
    41 !   [p_matrix]        pressure profile (hPa)
    42 !   [t_matrix]        temperature profile (C)
    43 !   [rh_matrix]       relative humidity profile (%)
     42!   [re_matrix]       table of hydrometeor effective radii.  0 ==> use defaults. (units=microns)   
     43!   [Np_matrix]       table of hydrometeor number concentration.  0 ==> use defaults. (units = 1/kg)
    4444!
    4545! Outputs:
     46!
    4647!   [Ze_non]          radar reflectivity without attenuation (dBZ)
    4748!   [Ze_ray]          Rayleigh reflectivity (dBZ)
    … …  
    5960! Created:
    6061!   11/28/2005  John Haynes (haynes@atmos.colostate.edu)
     62!
    6163! Modified:
    62 !   09/2006  placed into subroutine form, scaling factors (Roger Marchand,JMH)
     64!   09/2006  placed into subroutine form (Roger Marchand,JMH)
    6365!   08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
    6466!   01/2008  'Do while' to determine if hydrometeor(s) present in volume
    6567!             changed for vectorization purposes (A. Bodas-Salcedo)
    66 
     68!
     69!   07/2010  V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT)
     70!  ... All hydrometeor and radar simulator properties now included in hp structure
     71!  ... hp structure should be initialized by call to radar_simulator_init prior
     72!  ... to calling this subroutine. 
     73!     Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added
     74!  ... Changes implement by Roj Marchand following work by Laura Fowler
     75!
     76!   10/2011  Modified ngate loop to go in either direction depending on flag
     77!     hp%radar_at_layer_one.  This affects the direction in which attenuation is summed.
     78!
     79!     Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple
     80!     summation. (Roger Marchand)
     81!
     82!
    6783! ----- INPUTS ----- 
    68   type(mie), intent(in) :: mt
     84 
     85  logical, parameter  ::  DO_LUT_TEST = .false.
     86  logical, parameter  ::  DO_NP_TEST = .false.
     87
    6988  type(class_param), intent(inout) :: hp
    70   real*8, intent(in) :: freq,k2
    71   integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
    72     nhclass,nprof,ngate,nsizes
    73   real*8, dimension(nsizes), intent(in) :: D
    74   real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
    75     t_matrix,rh_matrix
    76   real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
    77   real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
    78    
     89
     90  integer, intent(in) ::  nprof,ngate
     91
     92  real undef
     93  real*8, dimension(nprof,ngate), intent(in) :: &
     94    hgt_matrix, p_matrix,t_matrix,rh_matrix
     95
     96  real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
     97  real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
     98  real*8, dimension(hp%nhclass,nprof,ngate), intent(in)    :: Np_matrix
     99
    79100! ----- OUTPUTS -----
    80101  real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
    81         g_atten_to_vol,dBZe,h_atten_to_vol
     102       g_to_vol,dBZe,a_to_vol
    82103
    83104! ----- OPTIONAL -----
    84   real*8, optional, dimension(ngate,nprof) :: &
     105  real*8, optional, dimension(nprof,ngate) :: &
    85106  g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input
    86107                           ! the same gaseous absorption in different calls. Optional to allow compatibility
    87108                           ! with original version. A. Bodas April 2008.
    88        
    89109!  real*8, dimension(nprof,ngate) :: kr_matrix
    90110
    91111! ----- INTERNAL -----
     112
     113  real, parameter :: one_third = 1.0/3.0
     114  real*8 :: t_kelvin
    92115  integer :: &
    93   phase, &                      ! 0=liquid, 1=ice
    94   ns                            ! number of discrete drop sizes
    95 
    96   integer*4, dimension(ngate) :: &
    97   hydro                         ! 1=hydrometeor in vol, 0=none
     116  phase, & ! 0=liquid, 1=ice
     117  ns       ! number of discrete drop sizes
     118
     119  logical :: hydro      ! true=hydrometeor in vol, false=none
    98120  real*8 :: &
    99   rho_a, &                      ! air density (kg m^-3)
    100   gases                         ! function: 2-way gas atten (dB/km)
     121  rho_a, &   ! air density (kg m^-3)
     122  gases      ! function: 2-way gas atten (dB/km)
    101123
    102124  real*8, dimension(:), allocatable :: &
    103   Di, Deq, &                    ! discrete drop sizes (um)
    104   Ni, Ntemp, &                  ! discrete concentrations (cm^-3 um^-1)
    105   rhoi                          ! discrete densities (kg m^-3)
    106  
    107   real*8, dimension(ngate) :: &
    108   z_vol, &                      ! effective reflectivity factor (mm^6/m^3)
     125  Di, Deq, &   ! discrete drop sizes (um)
     126  Ni, &        ! discrete concentrations (cm^-3 um^-1)
     127  rhoi         ! discrete densities (kg m^-3)
     128
     129  real*8, dimension(nprof, ngate) :: &
     130  z_vol, &      ! effective reflectivity factor (mm^6/m^3)
    109131  z_ray, &                      ! reflectivity factor, Rayleigh only (mm^6/m^3)
    110   kr_vol, &                     ! attenuation coefficient hydro (dB/km)
    111   g_vol, &                      ! attenuation coefficient gases (dB/km)
    112   a_to_vol, &                   ! integrated atten due to hydometeors, r>v (dB)
    113   g_to_vol                      ! integrated atten due to gases, r>v (dB)
    114    
    115  
     132  kr_vol, &     ! attenuation coefficient hydro (dB/km)
     133  g_vol         ! attenuation coefficient gases (dB/km)
     134
     135
    116136  integer,parameter :: KR8 = selected_real_kind(15,300)
    117137  real*8, parameter :: xx = -1.0_KR8
    118138  real*8,  dimension(:), allocatable :: xxa
    119   real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2,apm,bpm
     139  real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2, apm, bpm
     140  real*8 :: half_a_atten_current,half_a_atten_above
     141  real*8 :: half_g_atten_current,half_g_atten_above
    120142  integer*4 :: tp, i, j, k, pr, itt, iff
    121143
    122   real*8 bin_length,step,base,step_list(25),base_list(25)
     144  real*8    step,base, Np
    123145  integer*4 iRe_type,n,max_bin
    124  
     146
     147  integer   start_gate,end_gate,d_gate
     148
    125149  logical :: g_to_vol_in_present, g_to_vol_out_present
    126        
     150
    127151  ! Logicals to avoid calling present within the loops
    128152  g_to_vol_in_present  = present(g_to_vol_in)
    129153  g_to_vol_out_present = present(g_to_vol_out)
    130  
    131     ! set up Re bins for z_scalling
    132         bin_length=50;
    133         max_bin=25
    134 
    135         step_list(1)=1
    136         base_list(1)=75
    137         do j=2,max_bin
    138                 step_list(j)=3*(j-1);
    139                 if(step_list(j)>bin_length) then
    140                         step_list(j)=bin_length;
    141                 endif
    142                 base_list(j)=base_list(j-1)+floor(bin_length/step_list(j-1));
    143         enddo
    144 
     154
     155  !
     156  ! load scaling matricies from disk -- but only the first time this subroutine is called
     157  !
     158  if(hp%load_scale_LUTs) then
     159    call load_scale_LUTs(hp)
     160    hp%load_scale_LUTs=.false.
     161    hp%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run
     162  endif
    145163
    146164  pi = acos(-1.0)
    147   if (use_mie_table == 1) iff = infind(mt%freq,freq,sort=1)
    148 
    149        
     165
     166!   ----- Initialisation -----
     167  g_to_vol = 0.0
     168  a_to_vol = 0.0
     169  z_vol    = 0.0
     170  z_ray    = 0.0
     171  kr_vol   = 0.0
     172
     173!   // loop over each range gate (ngate) ... starting with layer closest to the radar !
     174  if(hp%radar_at_layer_one) then
     175    start_gate=1
     176    end_gate=ngate
     177    d_gate=1
     178  else
     179    start_gate=ngate
     180    end_gate=1
     181    d_gate=-1
     182  endif
     183  do k=start_gate,end_gate,d_gate
    150184  ! // loop over each profile (nprof)
    151   do pr=1,nprof
    152 
    153 !   ----- calculations for each volume -----
    154     z_vol(:) = 0
    155     z_ray(:) = 0
    156     kr_vol(:) = 0
    157     hydro(:) = 0   
    158 
    159 !   // loop over eacho range gate (ngate)
    160     do k=1,ngate
    161  
     185    do pr=1,nprof
     186      t_kelvin = t_matrix(pr,k)
    162187!     :: determine if hydrometeor(s) present in volume
    163       hydro(k) = 0
    164       do j=1,nhclass ! Do while changed for vectorization purposes (A. B-S)
     188      hydro = .false.
     189      do j=1,hp%nhclass
    165190        if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then
    166           hydro(k) = 1
     191          hydro = .true.
    167192          exit
    168193        endif
    169194      enddo
    170195
    171       if (hydro(k) == 1) then
    172 !     :: if there is hydrometeor in the volume           
    173 
    174         rho_a = (p_matrix(pr,k)*100.)/(287*(t_matrix(pr,k)+273.15))
    175 
     196!     :: if there is hydrometeor in the volume
     197      if (hydro) then
     198
     199        rho_a = (p_matrix(pr,k)*100.)/(287.0*(t_kelvin))
    176200!       :: loop over hydrometeor type
    177         do tp=1,nhclass
    178 
     201        do tp=1,hp%nhclass
    179202          if (hm_matrix(tp,pr,k) <= 1E-12) cycle
    180 
    181           phase = hp%phase(tp)
    182           if(phase==0) then
    183                 itt = infind(mt_ttl,t_matrix(pr,k))
    184           else
    185                 itt = infind(mt_tti,t_matrix(pr,k))
     203          phase = hp%phase(tp)
     204          if (phase==0) then
     205            itt = infind(hp%mt_ttl,t_kelvin)
     206          else
     207            itt = infind(hp%mt_tti,t_kelvin)
     208          endif
     209          if (re_matrix(tp,pr,k).eq.0) then
     210            call calc_Re(hm_matrix(tp,pr,k),Np_matrix(tp,pr,k),rho_a, &
     211              hp%dtype(tp),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
     212              hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),Re)
     213            re_matrix(tp,pr,k)=Re
     214          else
     215            if (Np_matrix(tp,pr,k)>0) then
     216               print *, 'Warning: Re and Np set for the same ', &
     217                        'volume & hydrometeor type.  Np is being ignored.'
     218            endif
     219            Re = re_matrix(tp,pr,k)
     220          endif
     221
     222          iRe_type=1
     223          if(Re.gt.0) then
     224            ! determine index in to scale LUT
     225            !
     226            ! distance between Re points (defined by "base" and "step") for
     227            ! each interval of size Re_BIN_LENGTH
     228            ! Integer asignment, avoids calling floor intrinsic
     229            n=Re/Re_BIN_LENGTH
     230            if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1
     231            step=hp%step_list(n+1)
     232            base=hp%base_list(n+1)
     233            iRe_type=Re/step
     234            if (iRe_type.lt.1) iRe_type=1
     235
     236            Re=step*(iRe_type+0.5)      ! set value of Re to closest value allowed in LUT.
     237            iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step)
     238
     239            ! make sure iRe_type is within bounds
     240            if (iRe_type.ge.nRe_types) then
     241!               write(*,*) 'Warning: size of Re exceed value permitted ', &
     242!                    'in Look-Up Table (LUT).  Will calculate. '
     243               ! no scaling allowed
     244               iRe_type=nRe_types
     245               hp%Z_scale_flag(tp,itt,iRe_type)=.false.
     246            else
     247               ! set value in re_matrix to closest values in LUT
     248              if (.not. DO_LUT_TEST) re_matrix(tp,pr,k)=Re
     249            endif
     250          endif
     251          ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
     252          ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
     253          if( (.not. hp%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST)  then
     254            ! :: create a distribution of hydrometeors within volume
     255            select case(hp%dtype(tp))
     256              case(4)
     257                ns = 1
     258                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
     259                Di = hp%p1(tp)
     260                Ni = 0.
     261              case default
     262                ns = nd   ! constant defined in radar_simulator_types.f90
     263                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
     264                Di = hp%D
     265                Ni = 0.
     266            end select
     267            call dsd(hm_matrix(tp,pr,k),re_matrix(tp,pr,k),Np_matrix(tp,pr,k), &
     268                     Di,Ni,ns,hp%dtype(tp),rho_a,t_kelvin, &
     269                     hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
     270                     hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp))
     271
     272            ! calculate particle density
     273            if (phase == 1) then
     274              if (hp%rho(tp) < 0) then
     275                ! Use equivalent volume spheres.
     276                hp%rho_eff(tp,1:ns,iRe_type) = 917                              ! solid ice == equivalent volume approach
     277                Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6
     278                ! alternative is to comment out above two lines and use the following block
     279                ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
     280                !
     281                ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
     282
     283                ! as the particle size gets small it is possible that the mass to size relationship of
     284                ! (given by power law in hclass.data) can produce impossible results
     285                ! where the mass is larger than a solid sphere of ice. 
     286                ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
     287                ! do i=1,ns
     288                ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
     289                ! hp%rho_eff(tp,i,iRe_type) = 917
     290                ! endif
     291                ! enddo
     292              else
     293                ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
     294                hp%rho_eff(tp,1:ns,iRe_type) = 917
     295                Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0))
     296                ! alternative ... coment out above two lines and use the following for MG-Mie
     297                ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
     298              endif
     299            else
     300              ! I assume here that water phase droplets are spheres.
     301              ! hp%rho should be ~ 1000  or hp%apm=524 .and. hp%bpm=3
     302              Deq = Di
     303            endif
     304
     305            ! calculate effective reflectivity factor of volume
     306            xxa = -9.9
     307            rhoi = hp%rho_eff(tp,1:ns,iRe_type)
     308            call zeff(hp%freq,Deq,Ni,ns,hp%k2,t_kelvin,phase,hp%do_ray, &
     309                      ze,zr,kr,xxa,xxa,rhoi)
     310
     311            ! test code ... compare Np value input to routine with sum of DSD
     312            ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation
     313            ! not just the DSD representation given by Ni
     314            if(Np_matrix(tp,pr,k)>0 .and. DO_NP_TEST ) then
     315              Np = path_integral(Ni,Di,1,ns-1)/rho_a*1E6
     316              ! Note: Representation is not great or small Re < 2
     317              if( (Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)>0.1 ) then
     318                write(*,*) 'Error: Np input does not match sum(N)'
     319                write(*,*) tp,pr,k,Re,Ni(1),Ni(ns),10*log10(ze)
     320                write(*,*) Np_matrix(tp,pr,k),Np,(Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)
     321                write(*,*)
     322              endif
     323            endif
     324
     325            deallocate(Di,Ni,rhoi,xxa,Deq)
     326
     327            ! LUT test code
     328            ! This segment of code compares full calculation to scaling result
     329            if ( hp%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST )  then
     330              scale_factor=rho_a*hm_matrix(tp,pr,k)
     331              ! if more than 2 dBZe difference print error message/parameters.
     332              if ( abs(10*log10(ze) - 10*log10(hp%Ze_scaled(tp,itt,iRe_type) * &
     333                   scale_factor)) > 2 ) then
     334                write(*,*) 'Roj Error: ',tp,itt,iRe_type,hp%Z_scale_flag(tp,itt,iRe_type),n,step,base
     335                write(*,*) 10*log10(ze),10*log10(hp%Ze_scaled(tp,itt,iRe_type) * scale_factor)
     336                write(*,*) hp%Ze_scaled(tp,itt,iRe_type),scale_factor
     337                write(*,*) re_matrix(tp,pr,k),Re
     338                write(*,*)
     339              endif
     340            endif
     341
     342          else ! can use z scaling
     343            scale_factor=rho_a*hm_matrix(tp,pr,k)
     344            zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor
     345            ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
     346            kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor
     347          endif  ! end z_scaling
     348
     349          kr_vol(pr,k) = kr_vol(pr,k) + kr
     350          z_vol(pr,k)  = z_vol(pr,k)  + ze
     351          z_ray(pr,k)  = z_ray(pr,k)  + zr
     352
     353          ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
     354          if ( .not. hp%Z_scale_flag(tp,itt,iRe_type) ) then
     355            if (iRe_type>1) then
     356              scale_factor=rho_a*hm_matrix(tp,pr,k)
     357              hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
     358              hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
     359              hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
     360              hp%Z_scale_flag(tp,itt,iRe_type) = .true.
     361              hp%Z_scale_added_flag(tp,itt,iRe_type)=.true.
     362            endif
     363          endif
     364
     365        enddo   ! end loop of tp (hydrometeor type)
     366
     367      else
     368!     :: volume is hydrometeor-free     
     369        kr_vol(pr,k) = 0
     370        z_vol(pr,k)  = undef
     371        z_ray(pr,k)  = undef
    186372      endif
    187373
    188           ! calculate Re if we have an exponential distribution with fixed No ... precipitation type particle
    189           if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8)  then
    190 
    191                 apm=hp%apm(tp)
    192                 bpm=hp%bpm(tp)
    193 
    194                 if ((hp%rho(tp) > 0) .and. (apm < 0)) then
    195                         apm = (pi/6)*hp%rho(tp)
    196                         bpm = 3.
    197                 endif
    198 
    199                 tmp1 = 1./(1.+bpm)
    200                 ld = ((apm*gamma(1.+bpm)*hp%p1(tp))/(rho_a*hm_matrix(tp,pr,k)*1E-3))**tmp1
    201                
    202                 Re = 1.5E6/ld
    203                
    204                 re_matrix(tp,pr,k) = Re;
    205 
    206           endif
    207  
    208           if(re_matrix(tp,pr,k).eq.0) then
    209 
    210                 iRe_type=1
    211                 Re=0
    212           else
    213                 iRe_type=1
    214                 Re=re_matrix(tp,pr,k)
    215                
    216                 n=floor(Re/bin_length)
    217                 if(n==0) then
    218                         if(Re<25) then
    219                                 step=0.5
    220                                 base=0
    221                         else                   
    222                                 step=1
    223                                 base=25
    224                         endif
    225                 else
    226                         if(n>max_bin) then
    227                                 n=max_bin       
    228                         endif
    229 
    230                         step=step_list(n)
    231                         base=base_list(n)
    232                 endif
    233 
    234                 iRe_type=floor(Re/step)
    235 
    236                 if(iRe_type.lt.1) then 
    237                         iRe_type=1                     
    238                 endif
    239 
    240                 Re=step*(iRe_type+0.5)
    241                 iRe_type=iRe_type+base-floor(n*bin_length/step)
    242 
    243                 ! make sure iRe_type is within bounds
    244                 if(iRe_type.ge.nRe_types) then 
    245 
    246                         ! print *, tp, re_matrix(tp,pr,k), Re, iRe_type
    247 
    248                         ! no scaling allowed
    249                         Re=re_matrix(tp,pr,k)
    250 
    251                         iRe_type=nRe_types
    252                         hp%z_flag(tp,itt,iRe_type)=.false.
    253                         hp%scaled(tp,iRe_type)=.false.                 
    254                 endif
    255           endif
    256        
    257           ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
    258           ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
    259           if( .not. hp%z_flag(tp,itt,iRe_type) )  then
    260          
    261 !         :: create a distribution of hydrometeors within volume         
    262           select case(hp%dtype(tp))
    263           case(4)
    264             ns = 1
    265             allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
    266             if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))
    267             Di = hp%p1(tp)
    268             Ni = 0.
    269           case default
    270             ns = nsizes           
    271             allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
    272             if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))           
    273             Di = D
    274             Ni = 0.
    275           end select
    276 
    277 !         :: create a DSD (using scaling factor if applicable)
    278           ! hp%scaled(tp,iRe_type)=.false.   ! turn off N scaling
    279 
    280           call dsd(hm_matrix(tp,pr,k),Re,Di,Ni,ns,hp%dtype(tp),rho_a, &
    281             t_matrix(pr,k),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
    282             hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),hp%fc(tp,1:ns,iRe_type), &
    283             hp%scaled(tp,iRe_type))
    284 
    285 !         :: calculate particle density
    286           ! if ((hp%rho_eff(tp,1,iRe_type) < 0) .and. (phase == 1)) then
    287           if (phase == 1) then
    288             if (hp%rho(tp) < 0) then
    289                
    290                 ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density               
    291                 ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
    292                
    293                 ! as the particle size gets small it is possible that the mass to size relationship of
    294                 ! (given by power law in hclass.data) can produce impossible results
    295                 ! where the mass is larger than a solid sphere of ice. 
    296                 ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
    297                 ! do i=1,ns
    298                 ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
    299                 !       hp%rho_eff(tp,i,iRe_type) = 917
    300                 !endif
    301                 !enddo
    302 
    303                 ! alternative is to use equivalent volume spheres.
    304                 hp%rho_eff(tp,1:ns,iRe_type) = 917                              ! solid ice == equivalent volume approach
    305                 Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * &
    306                            ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6             ! Di now really Deq in microns.
    307                
     374      !     :: attenuation due to hydrometeors between radar and volume
     375      !
     376      ! NOTE old scheme integrates attenuation only for the layers ABOVE
     377      ! the current layer ... i.e. 1 to k-1 rather than 1 to k ...
     378      ! which may be a problem.   ROJ
     379      ! in the new scheme I assign half the attenuation to the current layer
     380      if(d_gate==1) then
     381        ! dheight calcuations assumes hgt_matrix points are the cell mid-points.
     382        if (k>2) then
     383          ! add to previous value to half of above layer + half of current layer
     384          a_to_vol(pr,k)=  a_to_vol(pr,k-1) + &
     385             (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
     386        else
     387          a_to_vol(pr,k)=  kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
     388        endif
     389      else   ! d_gate==-1
     390        if(k<ngate) then
     391          ! add to previous value half of above layer + half of current layer
     392          a_to_vol(pr,k) = a_to_vol(pr,k+1) + &
     393              (kr_vol(pr,k+1)+kr_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
     394        else
     395          a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
     396        endif
     397      endif
     398
     399      !     :: attenuation due to gaseous absorption between radar and volume
     400      if (g_to_vol_in_present) then
     401        g_to_vol(pr,k) = g_to_vol_in(pr,k)
     402      else
     403        if ( (hp%use_gas_abs == 1) .or. ((hp%use_gas_abs == 2) .and. (pr == 1)) ) then
     404          g_vol(pr,k) = gases(p_matrix(pr,k),t_kelvin,rh_matrix(pr,k),hp%freq)
     405          if (d_gate==1) then
     406            if (k>1) then
     407              ! add to previous value to half of above layer + half of current layer
     408              g_to_vol(pr,k) =  g_to_vol(pr,k-1) + &
     409                  0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
    308410            else
    309 
    310                 ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
    311                
    312                 ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
    313                 hp%rho_eff(tp,1:ns,iRe_type) = 917
    314                 Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0)) 
    315 
    316             endif
    317 
    318                 ! if using equivalent volume spheres
    319                 if (use_mie_table == 1) then
    320 
    321                         Ntemp=Ni
    322 
    323                         ! Find N(Di) from N(Deq) which we know
    324                         do i=1,ns
    325                                 j=infind(Deq,Di(i))
    326                                 Ni(i)=Ntemp(j)
    327                         enddo
    328                 else
    329                         ! just use Deq and D variable input to mie code
    330                         Di=Deq;
    331                 endif
    332 
    333           endif
    334           rhoi = hp%rho_eff(tp,1:ns,iRe_type)
    335          
    336 !         :: calculate effective reflectivity factor of volume
    337           if (use_mie_table == 1) then
    338          
    339             if ((hp%dtype(tp) == 4) .and. (hp%idd(tp) < 0)) then
    340               hp%idd(tp) = infind(mt%D,Di(1))
    341             endif
    342            
    343             if (phase == 0) then
    344            
    345               ! itt = infind(mt_ttl,t_matrix(pr,k))
    346               select case(hp%dtype(tp))
    347               case(4)
    348                 mt_qext(1) = mt%qext(hp%idd(tp),itt,1,iff)
    349                 mt_qbsca(1) = mt%qbsca(hp%idd(tp),itt,1,iff)
    350               case default
    351                 mt_qext = mt%qext(:,itt,1,iff)
    352                 mt_qbsca = mt%qbsca(:,itt,1,iff)
    353               end select
    354 
    355           call zeff(freq,Di,Ni,ns,k2,mt_ttl(itt),0,do_ray, &
    356                 ze,zr,kr,mt_qext,mt_qbsca,xx)
    357            
    358             else
    359 
    360               ! itt = infind(mt_tti,t_matrix(pr,k))
    361               select case(hp%dtype(tp))
    362               case(4)
    363                 if (hp%ifc(tp,1,iRe_type) < 0) then
    364                   hp%ifc(tp,1,iRe_type) = infind(mt%f,rhoi(1)/917.)
    365                 endif                 
    366                 mt_qext(1) = &
    367                   mt%qext(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)
    368                 mt_qbsca(1) = &
    369                   mt%qbsca(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)         
    370               case default
    371                 do i=1,ns
    372                   if (hp%ifc(tp,i,iRe_type) < 0) then
    373                     hp%ifc(tp,i,iRe_type) = infind(mt%f,rhoi(i)/917.)
    374                   endif       
    375                   mt_qext(i) = mt%qext(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
    376                   mt_qbsca(i) = mt%qbsca(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
    377                 enddo
    378               end select
    379 
    380                    call zeff(freq,Di,Ni,ns,k2,mt_tti(itt),1,do_ray, &
    381                 ze,zr,kr,mt_qext,mt_qbsca,xx)
    382 
    383             endif
    384 
    385           else
    386        
    387             xxa = -9.9
    388             call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
    389               ze,zr,kr,xxa,xxa,rhoi)
    390 
    391              
    392           endif  ! end of use mie table
    393 
    394                 ! xxa = -9.9
    395                 !call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
    396                 !       ze2,zr,kr2,xxa,xxa,rhoi)
    397 
    398                 ! if(abs(ze2-ze)/ze2 > 0.1) then
    399                 ! if(abs(kr2-kr)/kr2 > 0.1) then
    400                
    401                 ! write(*,*) pr,k,tp,ze2,ze2-ze,abs(ze2-ze)/ze2,itt+cnt_liq,iff
    402                 ! write(*,*) pr,k,tp,ze2,kr2,kr2-kr,abs(kr2-kr)/kr2
    403                 ! stop
    404 
    405                 !endif
    406 
    407           deallocate(Di,Ni,rhoi,xxa,Deq)
    408           if (use_mie_table == 1) deallocate(mt_qext,mt_qbsca,Ntemp)
    409 
    410           else ! can use z scaling
    411          
    412                 if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 )  then
    413                  
    414                         ze = hp%Ze_scaled(tp,itt,iRe_type)
    415                         zr = hp%Zr_scaled(tp,itt,iRe_type)
    416                         kr = hp%kr_scaled(tp,itt,iRe_type)
    417 
    418                 else
    419                         scale_factor=rho_a*hm_matrix(tp,pr,k)
    420 
    421                         zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor
    422                         ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
    423                         kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor       
    424                 endif
    425 
    426           endif  ! end z_scaling
    427  
    428           ! kr=0
    429 
    430           kr_vol(k) = kr_vol(k) + kr
    431           z_vol(k) = z_vol(k) + ze
    432           z_ray(k) = z_ray(k) + zr
    433        
    434           ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
    435           if( .not. hp%z_flag(tp,itt,iRe_type) .and. 1.eq.1 ) then
    436 
    437                 if( ( (hp%dtype(tp)==1 .or. hp%dtype(tp)==5 .or.  hp%dtype(tp)==2)  .and. abs(hp%p1(tp)+1) < 1E-8  ) .or. &
    438                     (  hp%dtype(tp)==3 .or. hp%dtype(tp)==4 )  &
    439                 ) then
    440 
    441                         scale_factor=rho_a*hm_matrix(tp,pr,k)
    442 
    443                         hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
    444                         hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
    445                         hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
    446 
    447                         hp%z_flag(tp,itt,iRe_type)=.True.
    448 
    449                 elseif( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then
    450                  
    451                         hp%Ze_scaled(tp,itt,iRe_type) = ze
    452                         hp%Zr_scaled(tp,itt,iRe_type) = zr
    453                         hp%kr_scaled(tp,itt,iRe_type) = kr
    454 
    455                         hp%z_flag(tp,itt,iRe_type)=.True.
    456                 endif
    457 
    458           endif
    459 
    460         enddo   ! end loop of tp (hydrometeor type)
    461 
     411              g_to_vol(pr,k)=  0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
     412            endif
     413          else   ! d_gate==-1
     414            if (k<ngate) then
     415              ! add to previous value to half of above layer + half of current layer
     416              g_to_vol(pr,k) = g_to_vol(pr,k+1) + &
     417                 0.5*(g_vol(pr,k+1)+g_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
     418            else
     419              g_to_vol(pr,k)= 0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
     420            endif
     421          endif
     422        elseif(hp%use_gas_abs == 2) then
     423          ! using value calculated for the first column
     424          g_to_vol(pr,k) = g_to_vol(1,k)
     425        elseif (hp%use_gas_abs == 0) then
     426          g_to_vol(pr,k) = 0
     427        endif
     428      endif
     429
     430      ! Compute Rayleigh reflectivity, and full, attenuated reflectivity
     431      if ((hp%do_ray == 1) .and. (z_ray(pr,k) > 0)) then
     432        Ze_ray(pr,k) = 10*log10(z_ray(pr,k))
    462433      else
    463 !     :: volume is hydrometeor-free
    464        
    465         kr_vol(k) = 0
    466         z_vol(k) = -999
    467         z_ray(k) = -999
    468        
     434        Ze_ray(pr,k) = undef
    469435      endif
    470 
    471 !     :: attenuation due to hydrometeors between radar and volume
    472       a_to_vol(k) = 2*path_integral(kr_vol,hgt_matrix(pr,:),1,k-1)
    473      
    474 !     :: attenuation due to gaseous absorption between radar and volume
    475       if (g_to_vol_in_present) then
    476         g_to_vol(k) = g_to_vol_in(k,pr)
     436      if (z_vol(pr,k) > 0) then
     437        Ze_non(pr,k) = 10*log10(z_vol(pr,k))
     438        dBZe(pr,k) = Ze_non(pr,k)-a_to_vol(pr,k)-g_to_vol(pr,k)
    477439      else
    478         if ( (use_gas_abs == 1) .or. ((use_gas_abs == 2) .and. (pr == 1)) )  then
    479             g_vol(k) = gases(p_matrix(pr,k),t_matrix(pr,k)+273.15, &
    480             rh_matrix(pr,k),freq)
    481             g_to_vol(k) = path_integral(g_vol,hgt_matrix(pr,:),1,k-1)
    482         elseif (use_gas_abs == 0) then
    483             g_to_vol(k) = 0
    484         endif 
     440        dBZe(pr,k) = undef
     441        Ze_non(pr,k) = undef
    485442      endif
    486    
    487 !      kr_matrix(pr,:)=kr_vol
    488 
    489 !     :: store results in matrix for return to calling program
    490       h_atten_to_vol(pr,k)=a_to_vol(k)
    491       g_atten_to_vol(pr,k)=g_to_vol(k)
    492       if ((do_ray == 1) .and. (z_ray(k) > 0)) then
    493         Ze_ray(pr,k) = 10*log10(z_ray(k))
    494       else
    495         Ze_ray(pr,k) = -999
    496       endif
    497       if (z_vol(k) > 0) then
    498         dBZe(pr,k) = 10*log10(z_vol(k))-a_to_vol(k)-g_to_vol(k)
    499         Ze_non(pr,k) = 10*log10(z_vol(k))
    500       else
    501         dBZe(pr,k) = -999
    502         Ze_non(pr,k) = -999
    503       endif
    504      
    505     enddo       ! end loop of k (range gate)
    506     ! Output array with gaseous absorption
    507     if (g_to_vol_out_present) g_to_vol_out(:,pr) = g_to_vol
    508   enddo         ! end loop over pr (profile) 
     443
     444    enddo   ! end loop over pr (profile)
     445
     446  enddo ! end loop of k (range gate)
     447
     448  ! Output array with gaseous absorption
     449  if (g_to_vol_out_present) g_to_vol_out = g_to_vol
     450
     451  ! save any updates made
     452  if (hp%update_scale_LUTs) call save_scale_LUTs(hp)
    509453
    510454  end subroutine radar_simulator
    511  

  • LMDZ5/branches/testing/libf/phylmd/cosp/radar_simulator_types.F90

    r2298 r2435  
    33! Collection of common variables and types
    44! Part of QuickBeam v1.03 by John Haynes
    5 ! http://reef.atmos.colostate.edu/haynes/radarsim
     5! Updated by Roj Marchand June 2010
    66
    77  integer, parameter ::       &
    8   maxhclass = 20             ,& ! max number of hydrometeor classes
    9   nd = 85                    ,& ! number of discrete particles 
    10   nRe_types = 250               ! number or Re size bins allowed in N and Z_scaled look up table
     8  maxhclass = 20         ,& ! max number of hydrometeor classes
     9  nRe_types = 550       ! max number or Re size bins allowed in N and Z_scaled look up table
    1110
     11  ! These variables define discrete diameters used to represent the DSDs.
     12  integer, parameter ::       &
     13  nd = 85               ! number of discrete particles used in construction DSDs
    1214  real*8, parameter ::        &
    1315  dmin = 0.1                 ,& ! min size of discrete particle
    14   dmax = 10000.                 ! max size of discrete particle
     16  dmax = 10000.                 ! max size of discrete particle
    1517   
    16   integer, parameter :: &
     18  integer, parameter :: &   ! These parameters used to define temperature intervals in mie LUTs
    1719  mt_nfreq = 5              , &
    18   mt_ntt = 39               , & ! num temperatures in table
    19   mt_nf = 14                , & ! number of ice fractions in table 
    20   mt_nd = 85                   ! num discrete mode-p drop sizes in table
     20  mt_ntt = 39               , & ! num temperatures in table
     21  mt_nf = 14            , & ! number of ice fractions in table 
     22  mt_nd = 85                    ! num discrete mode-p drop sizes in table
     23
     24  integer, parameter :: &   ! These parameters used to defines Re intervals in scale LUTs
     25  Re_BIN_LENGTH=10, &       
     26  Re_MAX_BIN=250
     27
     28  integer, parameter :: &   ! These parameters used to define Temperature invervals in scale LUTs
     29  cnt_liq = 19, &       ! liquid temperature count
     30  cnt_ice = 20          ! ice temperature count
    2131
    2232
    … …  
    2434 
    2535  type class_param
     36 
     37    ! variables used to store hydrometeor "default" properties
    2638    real*8,  dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
    2739    integer, dimension(maxhclass) :: dtype,col,cp,phase
    28     logical, dimension(maxhclass,nRe_types) :: scaled
    29     logical, dimension(maxhclass,mt_ntt,nRe_types) :: z_flag
     40 
     41    ! Radar properties
     42    real*8  :: freq,k2
     43    integer :: nhclass      ! number of hydrometeor classes in use
     44    integer :: use_gas_abs, do_ray
     45   
     46    ! defines location of radar relative to hgt_matrix.   
     47    logical :: radar_at_layer_one       ! if true radar is assume to be at the edge
     48                                        ! of the first layer, if the first layer is the
     49                                        ! surface than a ground-based radar.   If the
     50                                        ! first layer is the top-of-atmosphere, then
     51                                        ! a space borne radar.
     52   
     53    ! variables used to store Z scale factors
     54    character*240 :: scale_LUT_file_name
     55    logical :: load_scale_LUTs, update_scale_LUTs
     56    logical, dimension(maxhclass,nRe_types) :: N_scale_flag
     57    logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag
    3058    real*8,  dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
    3159    real*8,  dimension(maxhclass,nd,nRe_types) :: fc, rho_eff
    32     integer, dimension(maxhclass,nd,nRe_types) :: ifc
    33     integer, dimension(maxhclass) :: idd
     60
     61    ! used to determine Re index
     62    real*8  :: step_list(Re_MAX_BIN),base_list(Re_MAX_BIN)
     63 
     64    ! used to determine temperature index
     65    real*8 :: &
     66        mt_ttl(cnt_liq), &  ! liquid temperatures (K)
     67        mt_tti(cnt_ice)     ! ice temperatures (K)
     68
     69    real*8 :: D(nd) ! set of discrete diameters used to represent DSDs
     70
    3471  end type class_param
    35 
    36 ! ----- mie table structure -----
    3772 
    38   type mie
    39     real*8 :: freq(mt_nfreq), tt(mt_ntt), f(mt_nf), D(mt_nd)
    40     real*8, dimension(mt_nd,mt_ntt,mt_nf,mt_nfreq) :: qext, qbsca
    41     integer :: phase(mt_ntt)
    42   end type mie
    43 
    44   real*8, dimension(:), save, allocatable :: &
    45     mt_ttl, &                   ! liquid temperatures (C)
    46     mt_tti, &                   ! ice temperatures (C)
    47     mt_qext, mt_qbsca           ! extincion/backscatter efficiency
    48 !$OMP THREADPRIVATE(mt_ttl,mt_tti,mt_qext, mt_qbsca)
    49 
    50   integer*4,save :: &
    51     cnt_liq, &                  ! liquid temperature count
    52     cnt_ice                     ! ice temperature count
    53 !$OMP THREADPRIVATE(cnt_liq,cnt_ice)
    54 
     73   
    5574  end module radar_simulator_types

  • LMDZ5/branches/testing/libf/phylmd/cosp/read_cosp_output_nl.F90

    r2298 r2435  
    1111  integer :: i
    1212
    13   logical, save ::   Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
    14              Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
    15              Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
    16              Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
    17              Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
    18              Lfrac_out,Lbeta_mol532,Ltbrttov
    19 
    20   namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
    21              Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
    22              Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, &
    23              Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, &
    24              Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
    25              Lfrac_out,Lbeta_mol532,Ltbrttov
    26 
     13!! AI
     14!  logical, save ::   Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
     15!             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
     16!             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
     17!             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
     18!             Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
     19!             Lfrac_out,Lbeta_mol532,Ltbrttov
     20
     21!  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
     22!             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
     23!             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, &
     24!             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, &
     25!             Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
     26!             Lfrac_out,Lbeta_mol532,Ltbrttov
     27!!
     28
     29 logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
     30             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
     31             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
     32             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
     33             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
     34             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
     35             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
     36             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
     37             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
     38             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
     39             Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
     40             Lfracout,LlidarBetaMol532,Ltbrttov, &
     41             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
     42             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
     43             Liwpmodis,Lclmodis
     44
     45  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
     46             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
     47             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp, &
     48             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp, &
     49             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
     50             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
     51             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
     52             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
     53             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
     54             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
     55             Lcltisccp,Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
     56             Lfracout,LlidarBetaMol532,Ltbrttov, &
     57             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
     58             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
     59             Liwpmodis,Lclmodis
     60   
    2761  do i=1,N_OUT_LIST
    2862    cfg%out_list(i)=''
    … …  
    3872  CALL bcast(Llidar_sim)
    3973  CALL bcast(Lisccp_sim)
     74  CALL bcast(Lmodis_sim)
    4075  CALL bcast(Lmisr_sim)
    4176  CALL bcast(Lrttov_sim)
    … …  
    4984  CALL bcast(Lclcalipso)
    5085  CALL bcast(Lclhcalipso)
     86  CALL bcast(Lclcalipsoliq)
     87  CALL bcast(Lclcalipsoice)
     88  CALL bcast(Lclcalipsoun)
     89  CALL bcast(Lclcalipsotmp)
     90  CALL bcast(Lclcalipsotmpliq)
     91  CALL bcast(Lclcalipsotmpice)
     92  CALL bcast(Lclcalipsotmpun)
     93  CALL bcast(Lcltcalipsoliq)
     94  CALL bcast(Lcltcalipsoice)
     95  CALL bcast(Lcltcalipsoun)
     96  CALL bcast(Lclhcalipsoliq)
     97  CALL bcast(Lclhcalipsoice)
     98  CALL bcast(Lclhcalipsoun)
     99  CALL bcast(Lclmcalipsoliq)
     100  CALL bcast(Lclmcalipsoice)
     101  CALL bcast(Lclmcalipsoun)
     102  CALL bcast(Lcllcalipsoliq)
     103  CALL bcast(Lcllcalipsoice)
     104  CALL bcast(Lcllcalipsoun)
    51105  CALL bcast(Lclisccp2)
    52106  CALL bcast(Lcllcalipso)
    … …  
    57111  CALL bcast(Ldbze94)
    58112  CALL bcast(Ltauisccp)
    59   CALL bcast(Ltclisccp)
    60   CALL bcast(Llongitude)
    61   CALL bcast(Llatitude)
     113  CALL bcast(Lcltisccp)
    62114  CALL bcast(Lparasol_refl)
    63115  CALL bcast(LclMISR)
    … …  
    66118  CALL bcast(Lfrac_out)
    67119  CALL bcast(Lbeta_mol532)
     120  CALL bcast(Lcltmodis)
     121  CALL bcast(Lclwmodis)
     122  CALL bcast(Lclimodis)
     123  CALL bcast(Lclhmodis)
     124  CALL bcast(Lclmmodis)
     125  CALL bcast(Lcllmodis)
     126  CALL bcast(Ltautmodis)
     127  CALL bcast(Ltauwmodis)
     128  CALL bcast(Ltauimodis)
     129  CALL bcast(Ltautlogmodis)
     130  CALL bcast(Ltauwlogmodis)
     131  CALL bcast(Ltauilogmodis)
     132  CALL bcast(Lreffclwmodis)
     133  CALL bcast(Lreffclimodis)
     134  CALL bcast(Lpctmodis)
     135  CALL bcast(Llwpmodis)
     136  CALL bcast(Liwpmodis)
     137  CALL bcast(Lclmodis)
    68138  CALL bcast(Ltbrttov)
    69139!$OMP BARRIER
    … …  
    92162    Lparasol_refl    = .false.
    93163    Lbeta_mol532     = .false.
     164!! AI
     165    Lclcalipsoliq    = .false.
     166    Lclcalipsoice    = .false.
     167    Lclcalipsoun    = .false.
     168    Lclcalipsotmp    = .false.
     169    Lclcalipsotmpun    = .false.
     170    Lclcalipsotmpliq    = .false.
     171    Lclcalipsotmpice    = .false.
     172    Lclhcalipsoliq      = .false.
     173    Lcllcalipsoliq      = .false.
     174    Lclmcalipsoliq     = .false.
     175    Lcltcalipsoliq      = .false.
     176    Lclhcalipsoice      = .false.
     177    Lcllcalipsoice      = .false.
     178    Lclmcalipsoice      = .false.
     179    Lcltcalipsoice      = .false.
     180    Lclhcalipsoun      = .false.
     181    Lcllcalipsoun      = .false.
     182    Lclmcalipsoun      = .false.
     183    Lcltcalipsoun      = .false.
    94184  endif
    95185  if (.not.Lisccp_sim) then
    … …  
    114204    Lfrac_out = .false.
    115205  endif
     206 if (.not.Lmodis_sim) then
     207    Lcltmodis=.false.
     208    Lclwmodis=.false.
     209    Lclimodis=.false.
     210    Lclhmodis=.false.
     211    Lclmmodis=.false.
     212    Lcllmodis=.false.
     213    Ltautmodis=.false.
     214    Ltauwmodis=.false.
     215    Ltauimodis=.false.
     216    Ltautlogmodis=.false.
     217    Ltauwlogmodis=.false.
     218    Ltauilogmodis=.false.
     219    Lreffclwmodis=.false.
     220    Lreffclimodis=.false.
     221    Lpctmodis=.false.
     222    Llwpmodis=.false.
     223    Liwpmodis=.false.
     224    Lclmodis=.false.
     225  endif
     226  if (Lmodis_sim) Lisccp_sim = .true.
    116227
    117228  ! Diagnostics that use Radar and Lidar
    … …  
    130241  cfg%Llidar_sim = Llidar_sim
    131242  cfg%Lisccp_sim = Lisccp_sim
     243  cfg%Lmodis_sim = Lmodis_sim
    132244  cfg%Lmisr_sim  = Lmisr_sim
    133245  cfg%Lrttov_sim = Lrttov_sim
    … …  
    149261  if (Lboxtauisccp)     cfg%out_list(i) = 'boxtauisccp'
    150262  i = i+1
    151   if (Lcfad_dbze94)     cfg%out_list(i) = 'cfad_dbze94'
    152   i = i+1
    153   if (Lcfad_lidarsr532) cfg%out_list(i) = 'cfad_lidarsr532'
     263  if (LcfadDbze94)      cfg%out_list(i) = 'cfadDbze94'
     264  i = i+1
     265  if (LcfadLidarsr532)  cfg%out_list(i) = 'cfadLidarsr532'
    154266  i = i+1
    155267  if (Lclcalipso2)      cfg%out_list(i) = 'clcalipso2'
    … …  
    159271  if (Lclhcalipso)      cfg%out_list(i) = 'clhcalipso'
    160272  i = i+1
    161   if (Lclisccp2)        cfg%out_list(i) = 'clisccp2'
     273  if (Lclisccp)         cfg%out_list(i) = 'clisccp'
    162274  i = i+1
    163275  if (Lcllcalipso)      cfg%out_list(i) = 'cllcalipso'
    … …  
    167279  if (Lcltcalipso)      cfg%out_list(i) = 'cltcalipso'
    168280  i = i+1
     281
     282  if (Lcllcalipsoice)      cfg%out_list(i) = 'cllcalipsoice'
     283  i = i+1
     284  if (Lclmcalipsoice)      cfg%out_list(i) = 'clmcalipsoice'
     285  i = i+1
     286  if (Lclhcalipsoice)      cfg%out_list(i) = 'clhcalipsoice'
     287  i = i+1
     288  if (Lcltcalipsoice)      cfg%out_list(i) = 'cltcalipsoice'
     289  i = i+1
     290  if (Lcllcalipsoliq)      cfg%out_list(i) = 'cllcalipsoliq'
     291  i = i+1
     292  if (Lclmcalipsoliq)      cfg%out_list(i) = 'clmcalipsoliq'
     293  i = i+1
     294  if (Lclhcalipsoliq)      cfg%out_list(i) = 'clhcalipsoliq'
     295  i = i+1
     296  if (Lcltcalipsoliq)      cfg%out_list(i) = 'cltcalipsoliq'
     297  i = i+1
     298  if (Lcllcalipsoun)      cfg%out_list(i) = 'cllcalipsoun'
     299  i = i+1
     300  if (Lclmcalipsoun)      cfg%out_list(i) = 'clmcalipsoun'
     301  i = i+1
     302  if (Lclhcalipsoun)      cfg%out_list(i) = 'clhcalipsoun'
     303  i = i+1
     304  if (Lcltcalipsoun)      cfg%out_list(i) = 'cltcalipsoun'
     305  i = i+1
     306
     307  if (Lclcalipsoice)       cfg%out_list(i) = 'clcalipsoice'
     308  i = i+1
     309  if (Lclcalipsoliq)       cfg%out_list(i) = 'clcalipsoliq'
     310  i = i+1
     311  if (Lclcalipsoun)       cfg%out_list(i) = 'clcalipsoun'
     312  i = i+1
     313
     314  if (Lclcalipsotmp)       cfg%out_list(i) = 'clcalipsotmp'
     315  i = i+1
     316  if (Lclcalipsotmpice)       cfg%out_list(i) = 'clcalipsotmpice'
     317  i = i+1
     318  if (Lclcalipsotmpliq)       cfg%out_list(i) = 'clcalipsotmpliq'
     319  i = i+1
     320  if (Lclcalipsotmpun)       cfg%out_list(i) = 'clcalipsotmpun'
     321  i = i+1
    169322  if (Lcltlidarradar)   cfg%out_list(i) = 'cltlidarradar'
    170323  i = i+1
    171   if (Lctpisccp)        cfg%out_list(i) = 'ctpisccp'
     324  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
    172325  i = i+1
    173326  if (Ldbze94)          cfg%out_list(i) = 'dbze94'
    … …  
    175328  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
    176329  i = i+1
    177   if (Ltclisccp)        cfg%out_list(i) = 'tclisccp'
    178   i = i+1
    179   if (Llongitude)       cfg%out_list(i) = 'lon'
    180   i = i+1
    181   if (Llatitude)        cfg%out_list(i) = 'lat'
    182   i = i+1
    183   if (Lparasol_refl)    cfg%out_list(i) = 'parasol_refl'
     330  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
     331  i = i+1
     332  if (Ltoffset)         cfg%out_list(i) = 'toffset'
     333  i = i+1
     334  if (LparasolRefl)     cfg%out_list(i) = 'parasolRefl'
    184335  i = i+1
    185336  if (LclMISR)          cfg%out_list(i) = 'clMISR'
    … …  
    189340  if (Lmeantbclrisccp)  cfg%out_list(i) = 'meantbclrisccp'
    190341  i = i+1
    191   if (Lfrac_out)        cfg%out_list(i) = 'frac_out'
    192   i = i+1
    193   if (Lbeta_mol532)     cfg%out_list(i) = 'beta_mol532'
     342  if (Lfracout)         cfg%out_list(i) = 'fracout'
     343  i = i+1
     344  if (LlidarBetaMol532) cfg%out_list(i) = 'lidarBetaMol532'
    194345  i = i+1
    195346  if (Ltbrttov)         cfg%out_list(i) = 'tbrttov'
    196 
     347  i = i+1
     348  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
     349  i = i+1
     350  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
     351  i = i+1
     352  if (Lclimodis)        cfg%out_list(i) = 'climodis'
     353  i = i+1
     354  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
     355  i = i+1
     356  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
     357  i = i+1
     358  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
     359  i = i+1
     360  if (Ltautmodis)       cfg%out_list(i) = 'tautmodis'
     361  i = i+1
     362  if (Ltauwmodis)       cfg%out_list(i) = 'tauwmodis'
     363  i = i+1
     364  if (Ltauimodis)       cfg%out_list(i) = 'tauimodis'
     365  i = i+1
     366  if (Ltautlogmodis)    cfg%out_list(i) = 'tautlogmodis'
     367  i = i+1
     368  if (Ltauwlogmodis)    cfg%out_list(i) = 'tauwlogmodis'
     369  i = i+1
     370  if (Ltauilogmodis)    cfg%out_list(i) = 'tauilogmodis'
     371  i = i+1
     372  if (Lreffclwmodis)    cfg%out_list(i) = 'reffclwmodis'
     373  i = i+1
     374  if (Lreffclimodis)    cfg%out_list(i) = 'reffclimodis'
     375  i = i+1
     376  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
     377  i = i+1
     378  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
     379  i = i+1
     380  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
     381  i = i+1
     382  if (Lclmodis)         cfg%out_list(i) = 'clmodis'
     383   
    197384  if (i /= N_OUT_LIST) then
    198385     print *, 'COSP_IO: wrong number of output diagnostics'
     386     print *, i,N_OUT_LIST
    199387     stop
    200388  endif
    201389
    202390  ! Copy diagnostic flags to cfg structure
     391  ! ISCCP simulator 
    203392  cfg%Lalbisccp = Lalbisccp
    204393  cfg%Latb532 = Latb532
    205394  cfg%Lboxptopisccp = Lboxptopisccp
    206395  cfg%Lboxtauisccp = Lboxtauisccp
    207   cfg%Lcfad_dbze94 = Lcfad_dbze94
    208   cfg%Lcfad_lidarsr532 = Lcfad_lidarsr532
     396  cfg%Lmeantbisccp = Lmeantbisccp
     397  cfg%Lmeantbclrisccp = Lmeantbclrisccp
     398  cfg%Lclisccp = Lclisccp
     399  cfg%Lpctisccp = Lpctisccp
     400  cfg%Ltauisccp = Ltauisccp
     401  cfg%Lcltisccp = Lcltisccp
     402  ! CloudSat simulator 
     403  cfg%Ldbze94 = Ldbze94
     404  cfg%LcfadDbze94 = LcfadDbze94
     405  ! CALIPSO/PARASOL simulator 
     406  cfg%LcfadLidarsr532 = LcfadLidarsr532
    209407  cfg%Lclcalipso2 = Lclcalipso2
    210408  cfg%Lclcalipso = Lclcalipso
    211409  cfg%Lclhcalipso = Lclhcalipso
    212   cfg%Lclisccp2 = Lclisccp2
    213410  cfg%Lcllcalipso = Lcllcalipso
    214411  cfg%Lclmcalipso = Lclmcalipso
    215412  cfg%Lcltcalipso = Lcltcalipso
     413  cfg%Lclhcalipsoice = Lclhcalipsoice
     414  cfg%Lcllcalipsoice = Lcllcalipsoice
     415  cfg%Lclmcalipsoice = Lclmcalipsoice
     416  cfg%Lcltcalipsoice = Lcltcalipsoice
     417  cfg%Lclhcalipsoliq = Lclhcalipsoliq
     418  cfg%Lcllcalipsoliq = Lcllcalipsoliq
     419  cfg%Lclmcalipsoliq = Lclmcalipsoliq
     420  cfg%Lcltcalipsoliq = Lcltcalipsoliq
     421  cfg%Lclhcalipsoun = Lclhcalipsoun
     422  cfg%Lcllcalipsoun = Lcllcalipsoun
     423  cfg%Lclmcalipsoun = Lclmcalipsoun
     424  cfg%Lcltcalipsoun = Lcltcalipsoun
     425  cfg%Lclcalipsoice = Lclcalipsoice
     426  cfg%Lclcalipsoliq = Lclcalipsoliq
     427  cfg%Lclcalipsoun = Lclcalipsoun
     428  cfg%Lclcalipsotmp = Lclcalipsotmp
     429  cfg%Lclcalipsotmpice = Lclcalipsotmpice
     430  cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
     431  cfg%Lclcalipsotmpun = Lclcalipsotmpun
    216432  cfg%Lcltlidarradar = Lcltlidarradar
    217   cfg%Lctpisccp = Lctpisccp
    218   cfg%Ldbze94 = Ldbze94
    219   cfg%Ltauisccp = Ltauisccp
    220   cfg%Ltclisccp = Ltclisccp
    221   cfg%Llongitude = Llongitude
    222   cfg%Llatitude = Llatitude
    223   cfg%Lparasol_refl = Lparasol_refl
     433  cfg%LparasolRefl = LparasolRefl
     434  ! MISR simulator 
    224435  cfg%LclMISR = LclMISR
    225   cfg%Lmeantbisccp = Lmeantbisccp
    226   cfg%Lmeantbclrisccp = Lmeantbclrisccp
    227   cfg%Lfrac_out = Lfrac_out
    228   cfg%Lbeta_mol532 = Lbeta_mol532
     436  ! Other
     437  cfg%Ltoffset = Ltoffset
     438  cfg%Lfracout = Lfracout
     439  cfg%LlidarBetaMol532 = LlidarBetaMol532
     440  ! RTTOV
    229441  cfg%Ltbrttov = Ltbrttov
    230 
     442  ! MODIS simulator 
     443  cfg%Lcltmodis=Lcltmodis
     444  cfg%Lclwmodis=Lclwmodis
     445  cfg%Lclimodis=Lclimodis
     446  cfg%Lclhmodis=Lclhmodis
     447  cfg%Lclmmodis=Lclmmodis
     448  cfg%Lcllmodis=Lcllmodis
     449  cfg%Ltautmodis=Ltautmodis
     450  cfg%Ltauwmodis=Ltauwmodis
     451  cfg%Ltauimodis=Ltauimodis
     452  cfg%Ltautlogmodis=Ltautlogmodis
     453  cfg%Ltauwlogmodis=Ltauwlogmodis
     454  cfg%Ltauilogmodis=Ltauilogmodis
     455  cfg%Lreffclwmodis=Lreffclwmodis
     456  cfg%Lreffclimodis=Lreffclimodis
     457  cfg%Lpctmodis=Lpctmodis
     458  cfg%Llwpmodis=Llwpmodis
     459  cfg%Liwpmodis=Liwpmodis
     460  cfg%Lclmodis=Lclmodis
     461 
    231462 END SUBROUTINE READ_COSP_OUTPUT_NL
    232463

  • LMDZ5/branches/testing/libf/phylmd/cosp/scops.F

    r2298 r2435  
    66! (c) British Crown Copyright 2009, the Met Office.
    77! All rights reserved.
     8! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
     9! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/scops.f $
    810!
    911! Redistribution and use in source and binary forms, with or without
    … …  
    3941! *****************************COPYRIGHT*******************************
    4042
    41       USE mod_phys_lmdz_para
    42       USE mod_grid_phy_lmdz
    43 
    4443      implicit none
    4544
    … …  
    178177          ELSE
    179178              DO ibox=1,ncol
    180 !                include 'congvec_para.h'
    181                  include 'congvec.h'
     179                include 'congvec.h'
    182180                ! select random pixels from the non-convective
    183181                ! part the gridbox ( some will be converted into
    … …  
    209207          do j=1,npoints
    210208            if (boxpos(j,ibox).le.conv(j,ilev)) then
    211               maxocc(j,ibox) = 1.
     209              maxocc(j,ibox) = 1
    212210            else
    213               maxocc(j,ibox) = 0.
     211              maxocc(j,ibox) = 0
    214212            end if
    215213          enddo

  • LMDZ5/branches/testing/libf/phylmd/cosp/zeff.F90

    r2298 r2435  
     1! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
     2! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/zeff.f90 $
    13  subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
    24  use math_lib
    … …  
    1517!   [nsizes]    number of discrete drop sizes
    1618!   [k2]        |K|^2, -1=use frequency dependent default
    17 !   [tt]        hydrometeor temperature (C)
     19!   [tt]        hydrometeor temperature (K)
    1820!   [ice]       indicates volume consists of ice
    1921!   [xr]        perform Rayleigh calculations?
    … …  
    4244! ----- INTERNAL -----
    4345  integer :: &
    44   correct_for_rho               ! correct for density flag
     46  correct_for_rho        ! correct for density flag
    4547  real*8, dimension(nsizes) :: &
    46   D0, &                         ! D in (m)
    47   N0, &                         ! N in m^-3 m^-1
    48   sizep, &                      ! size parameter
    49   qext, &                       ! extinction efficiency
    50   qbsca, &                      ! backscatter efficiency
    51   rho_ice, &                    ! bulk density ice (kg m^-3)
    52   f                             ! ice fraction
     48  D0, &                  ! D in (m)
     49  N0, &                  ! N in m^-3 m^-1
     50  sizep, &               ! size parameter
     51  qext, &           ! extinction efficiency
     52  qbsca, &               ! backscatter efficiency
     53  rho_ice, &             ! bulk density ice (kg m^-3)
     54  f                 ! ice fraction
     55  real*8, dimension(nsizes) :: xtemp
    5356  real*8 :: &
    54   wl, &                         ! wavelength (m)
     57  wl, &                  ! wavelength (m)
    5558  cr                            ! kr(dB/km) = cr * kr(1/km)
    5659  complex*16 :: &
    57   m                             ! complex index of refraction of bulk form
     60  m                 ! complex index of refraction of bulk form
    5861  complex*16, dimension(nsizes) :: &
    59   m0                            ! complex index of refraction
     62  m0                ! complex index of refraction
    6063 
    6164  integer*4 :: i,one
    6265  real*8 :: pi
    6366  real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, &
    64             n_r, n_i, dqv(1), dqxt, dqsc, dbsc, dg, dph(1)
     67            n_r, n_i, dqv(1), dqsc, dg, dph(1)
    6568  integer*4 :: err
    6669  complex*16 :: Xs1(1), Xs2(1)
    … …  
    7275
    7376! // conversions
    74   D0 = d*1E-6                   ! m
    75   N0 = n*1E12                   ! 1/(m^3 m)
    76   wl = 2.99792458/(freq*10)     ! m
     77  D0 = d*1E-6            ! m
     78  N0 = n*1E12            ! 1/(m^3 m)
     79  wl = 2.99792458/(freq*10)   ! m
    7780 
    7881! // dielectric constant |k^2| defaults
    … …  
    127130    eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2
    128131  else
    129     call avint(qbsca*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
     132    xtemp = qbsca*N0*D0**2
     133    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
    130134  endif
    131135 
    … …  
    140144    k_sum = qext(1)*(n(1)*1E6)*D0(1)**2
    141145  else
    142     call avint(qext*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
     146    xtemp = qext*N0*D0**2
     147    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
    143148  endif
    144149  cr = 10./log(10.)
    145150  kr = k_sum*0.25*pi*(1000.*cr)
    146        
     151     
    147152! // z_ray = sum[D^6*N(D)*deltaD]
    148153  if (xr == 1) then
    … …  
    151156      z0_ray = (n(1)*1E6)*D0(1)**6
    152157    else
    153       call avint(N0*D0**6,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
     158      xtemp = N0*D0**6
     159      call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
    154160    endif
    155161  endif

  • LMDZ5/branches/testing/libf/phylmd/cpl_mod.F90

    r2408 r2435  
    292292! are stored in this module.
    293293    USE surface_data
    294     USE phys_state_var_mod, ONLY : rlon, rlat
     294    USE geometry_mod, ONLY : longitude_deg, latitude_deg
    295295    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
    296296    USE indice_sol_mod
    … …  
    363363
    364364! Transform the longitudes and latitudes on 2D arrays
    365           CALL gather_omp(rlon,rlon_mpi)
    366           CALL gather_omp(rlat,rlat_mpi)
     365          CALL gather_omp(longitude_deg,rlon_mpi)
     366          CALL gather_omp(latitude_deg,rlat_mpi)
    367367!$OMP MASTER
    368368          CALL Grid1DTo2D_mpi(rlon_mpi,tmp_lon)
    … …  
    11151115   
    11161116      IF (is_parallel) THEN
    1117          IF (.NOT. is_north_pole) THEN
     1117         IF (.NOT. is_north_pole_dyn) THEN
    11181118#ifdef CPP_MPI
    11191119            CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
    … …  
    11221122         ENDIF
    11231123       
    1124          IF (.NOT. is_south_pole) THEN
     1124         IF (.NOT. is_south_pole_dyn) THEN
    11251125#ifdef CPP_MPI
    11261126            CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
    … …  
    11291129         ENDIF
    11301130         
    1131          IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
     1131         IF (.NOT. is_north_pole_dyn .AND. ii_begin /=1) THEN
    11321132            Up=Up+tmp_calv(nbp_lon,1)
    11331133            tmp_calv(:,1)=Up
    11341134         ENDIF
    11351135         
    1136          IF (.NOT. is_south_pole .AND. ii_end /= nbp_lon) THEN
     1136         IF (.NOT. is_south_pole_dyn .AND. ii_end /= nbp_lon) THEN
    11371137            Down=Down+tmp_calv(1,jj_nb)
    11381138            tmp_calv(:,jj_nb)=Down       
    … …  
    12221222
    12231223    IF (is_sequential) THEN
    1224        IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
    1225        IF (is_south_pole) tmp_lon(:,nbp_lat) = tmp_lon(:,nbp_lat-1)
     1224       IF (is_north_pole_dyn) tmp_lon(:,1)     = tmp_lon(:,2)
     1225       IF (is_south_pole_dyn) tmp_lon(:,nbp_lat) = tmp_lon(:,nbp_lat-1)
    12261226    ENDIF
    12271227     
    … …  
    13891389    CALL Grid1Dto2D_mpi(temp_mpi,champ_out)
    13901390   
    1391     IF (is_north_pole) champ_out(:,1)=temp_mpi(1)
    1392     IF (is_south_pole) champ_out(:,jj_nb)=temp_mpi(klon)
     1391    IF (is_north_pole_dyn) champ_out(:,1)=temp_mpi(1)
     1392    IF (is_south_pole_dyn) champ_out(:,jj_nb)=temp_mpi(klon)
    13931393!$OMP END MASTER
    13941394   

  • LMDZ5/branches/testing/libf/phylmd/cv3_buoy.F90

    r1999 r2435  
    1414  include "cvthermo.h"
    1515  include "cv3param.h"
     16  include "YOMCST2.h"
    1617
    1718  ! input:
    … …  
    139140  END DO
    140141
    141 
     142!CR:Correction of buoy for what comes next
     143!keep flag or to modify in all cases?
     144  IF (iflag_mix_adiab.eq.1) THEN
     145  DO k = 1, nl
     146    DO il = 1, ncum
     147       IF ((k>=kmx(il)) .AND. (k<=inb(il)) .AND. (buoy(il,k).lt.0.)) THEN
     148          buoy(il,k)=buoy(il,k-1)
     149       END IF
     150    ENDDO
     151  ENDDO
     152  ENDIF
    142153
    143154  RETURN

  • LMDZ5/branches/testing/libf/phylmd/cv3_cine.F90

    r1999 r2435  
    3434  INTEGER itop(nloc), ineg(nloc), ilow(nloc)
    3535  INTEGER ifst(nloc), isublcl(nloc)
    36   LOGICAL lswitch(nloc), lswitch1(nloc), lswitch2(nloc)
     36  LOGICAL lswitch(nloc), lswitch1(nloc), lswitch2(nloc), lswitch3(nloc)
    3737  LOGICAL exist_lfc(nloc)
    3838  REAL dpmax
    … …  
    161161  END DO
    162162
     163  ! 1.2.1 Recompute itop (=1st layer with positive buoyancy above ineg)
     164  ! -------------------------------------------------------------------
     165
     166  DO il = 1, ncum
     167    IF (lswitch(il)) THEN
     168      itop(il) = nl - 1
     169    END IF
     170  END DO
     171
     172  DO k = nl, 1, -1
     173    DO il = 1, ncum
     174      IF (lswitch(il)) THEN
     175        IF (k>=ineg(il) .AND. buoy(il,k)>0) THEN
     176          itop(il) = k
     177        END IF
     178      END IF
     179    END DO
     180  END DO
     181
     182  ! If there is no layer with positive buoyancy above ineg, set Plfc,
     183  ! Cina and Cinb to arbitrary extreme values.
     184  DO il = 1, ncum
     185    IF (lswitch(il) .AND. itop(il) == nl - 1) THEN
     186      plfc(il) = 1.121
     187      cinb(il) = -1121.
     188      cina(il) = -1122.
     189    END IF
     190  END DO
     191
     192  DO il = 1, ncum
     193    lswitch3(il) = itop(il) < nl -1
     194    lswitch(il) = lswitch1(il) .AND. lswitch2(il) .AND. lswitch3(il)
     195  END DO
     196
    163197  DO il = 1, ncum
    164198    IF (lswitch(il)) THEN
    165199      cinb(il) = 0.
    166200
    167       ! 1.2.1  Calcul de la pression du niveau de flot. nulle juste au-dessus
     201      ! 1.2.2  Calcul de la pression du niveau de flot. nulle juste au-dessus
    168202      ! de LCL
    169203      ! ---------------------------------------------------------------------------
    … …  
    171205        ! In order to get P0, one may interpolate linearly buoyancies
    172206        ! between P(ineg) and P(ineg-1).
    173         p0(il) = (buoy(il,ineg(il))*p(il,ineg(il)-1)-buoy(il,ineg( &
    174           il)-1)*p(il,ineg(il)))/(buoy(il,ineg(il))-buoy(il,ineg(il)-1))
     207        p0(il) = (buoy(il,ineg(il))*p(il,ineg(il)-1)-buoy(il,ineg(il)-1)*p(il,ineg(il)))/ &
     208          (buoy(il,ineg(il))-buoy(il,ineg(il)-1))
    175209      ELSE
    176210        ! In order to get P0, one has to interpolate between P(ineg) and
    … …  
    180214      END IF
    181215    END IF
    182   END DO
    183 
    184   ! 1.2.2 Recompute itop (=1st layer with positive buoyancy above ineg)
    185   ! -------------------------------------------------------------------
    186   DO il = 1, ncum
    187     IF (lswitch(il)) THEN
    188       itop(il) = nl - 1
    189     END IF
    190   END DO
    191 
    192   DO k = nl, 1, -1
    193     DO il = 1, ncum
    194       IF (lswitch(il)) THEN
    195         IF (k>=ineg(il) .AND. buoy(il,k)>0) THEN
    196           itop(il) = k
    197         END IF
    198       END IF
    199     END DO
    200216  END DO
    201217

  • LMDZ5/branches/testing/libf/phylmd/cv3_routines.F90

    r2408 r2435  
    9393    tau = 8000.
    9494
     95! -- end of convection
     96
     97    tau_stop = 15000.
     98    ok_convstop = .False.
     99
     100    ok_intermittent = .False.
     101
    95102! -- interface cloud parameterization:
    96103
    … …  
    111118    READ (99, *, END=9998) flag_wb
    112119    READ (99, *, END=9998) wbmax
     120    READ (99, *, END=9998) ok_convstop
     121    READ (99, *, END=9998) tau_stop
     122    READ (99, *, END=9998) ok_intermittent
    1131239998 CONTINUE
    114124    CLOSE (99)
    … …  
    122132    WRITE (*, *) 'flag_wb =', flag_wb
    123133    WRITE (*, *) 'wbmax =', wbmax
     134    WRITE (*, *) 'ok_convstop =', ok_convstop
     135    WRITE (*, *) 'tau_stop =', tau_stop
     136    WRITE (*, *) 'ok_intermittent =', ok_intermittent
    124137
    125138! IM Lecture du fichier ep_param.data
    … …  
    145158   CALL bcast(flag_wb)
    146159   CALL bcast(wbmax)
     160   CALL bcast(ok_convstop)
     161   CALL bcast(tau_stop)
     162   CALL bcast(ok_intermittent)
    147163
    148164   CALL bcast(flag_epkeorig)
    … …  
    163179! c      alpha  = alpha*1.5
    164180
     181  noconv_stop = max(2.,tau_stop/delt)
     182
    165183  RETURN
    166184END SUBROUTINE cv3_param
     185
     186SUBROUTINE cv3_incrcount(len, nd, delt, sig)
     187
     188IMPLICIT NONE
     189
     190! =====================================================================
     191!  Increment the counter sig(nd)
     192! =====================================================================
     193
     194  include "cv3param.h"
     195
     196!inputs:
     197  INTEGER, INTENT(IN)                     :: len
     198  INTEGER, INTENT(IN)                     :: nd
     199  REAL, INTENT(IN)                        :: delt ! timestep (seconds)
     200
     201!input/output
     202  REAL, DIMENSION(len,nd), INTENT(INOUT)  :: sig
     203
     204!local variables
     205  INTEGER il
     206
     207!    print *,'cv3_incrcount : noconv_stop ',noconv_stop
     208!    print *,'cv3_incrcount in, sig(1,nd) ',sig(1,nd)
     209    IF(ok_convstop) THEN
     210      DO il = 1, len
     211        sig(il, nd) = sig(il, nd) + 1.
     212        sig(il, nd) = min(sig(il,nd), noconv_stop+0.1)
     213      END DO
     214    ELSE
     215      DO il = 1, len
     216        sig(il, nd) = sig(il, nd) + 1.
     217        sig(il, nd) = min(sig(il,nd), 12.1)
     218      END DO
     219    ENDIF  ! (ok_convstop)
     220!    print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd)
     221
     222  RETURN
     223END SUBROUTINE cv3_incrcount
    167224
    168225SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, &
    … …  
    10301087SUBROUTINE cv3_undilute2(nloc, ncum, nd, icb, icbs, nk, &
    10311088                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
    1032                          p, h, tv, lv, lf, pbase, buoybase, plcl, &
     1089                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
    10331090                         inb, tp, tvp, clw, hp, ep, sigp, buoy, frac)
    10341091  IMPLICIT NONE
    … …  
    10561113  include "conema3.h"
    10571114  include "cvflag.h"
     1115  include "YOMCST2.h"
    10581116
    10591117!inputs:
    … …  
    10621120  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, q, qs, gz
    10631121  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
     1122  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
    10641123  REAL, DIMENSION (nloc), INTENT (IN)                :: tnk, qnk, gznk
    10651124  REAL, DIMENSION (nloc), INTENT (IN)                :: hnk
    … …  
    10871146  INTEGER iposit(nloc)
    10881147  REAL fracg
     1148  REAL deltap
    10891149
    10901150! =====================================================================
    … …  
    14191479    END DO
    14201480  END DO
     1481
     1482!CR fix computation of inb
     1483!keep flag or modify in all cases?
     1484  IF (iflag_mix_adiab.eq.1) THEN
     1485  DO i = 1, ncum
     1486     cape(i)=0.
     1487     inb(i)=icb(i)+1
     1488  ENDDO
     1489 
     1490  DO k = 2, nl
     1491    DO i = 1, ncum
     1492       IF ((k>=iposit(i))) THEN
     1493       deltap = min(plcl(i), ph(i,k-1)) - min(plcl(i), ph(i,k))
     1494       cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
     1495       IF (cape(i).gt.0.) THEN
     1496        inb(i) = max(inb(i), k)
     1497       END IF
     1498       ENDIF
     1499    ENDDO
     1500  ENDDO
     1501
     1502!  DO i = 1, ncum
     1503!     print*,"inb",inb(i)
     1504!  ENDDO
     1505
     1506  endif
    14211507
    14221508! -- end convect3

  • LMDZ5/branches/testing/libf/phylmd/cv3p1_closure.F90

    r2408 r2435  
    5858  INTEGER il, i, j, k, icbmax, i0(nloc), klfc(nloc)
    5959  REAL deltap, fac, w, amu
    60   REAL rhodp
     60  REAL rhodp, dz
    6161  REAL pbmxup
    6262  REAL dtmin(nloc, nd), sigold(nloc, nd)
    … …  
    7979  REAL term1, term2, term3
    8080  REAL alp2(nloc) ! Alp with offset
     81  !CR: variables for new erosion of adiabiatic ascent
     82  REAL mad(nloc, nd), me(nloc, nd), betalim(nloc, nd), beta_coef(nloc, nd)
     83  REAL med(nloc, nd), md(nloc,nd)
     84  REAL coef_peel
     85  PARAMETER (coef_peel=0.25)
    8186
    8287  REAL sigmax
    … …  
    110115    END DO
    111116  END DO
     117
     118!CR: initializations for erosion of adiabatic ascent
     119  DO k = 1,nl
     120    DO il = 1, ncum
     121        mad(il,k)=0.
     122        me(il,k)=0.
     123        betalim(il,k)=1.
     124        wlim(il,k)=0.
     125    ENDDO
     126  ENDDO
    112127
    113128  ! -------------------------------------------------------
    … …  
    431446
    432447      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
    433 
     448        IF (iflag_mix_adiab.eq.1) THEN
     449!CR:computation of cape from LCL: keep flag or to modify in all cases?
     450        deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k))
     451        ELSE
    434452        deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k))
     453        ENDIF
    435454        cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1)
    436455        cape(il) = amax1(0.0, cape(il))
    … …  
    601620  IF (prt_level>=20) PRINT *, 'cv3p1_param apres w0_sig_M'
    602621
     622!CR: new erosion of adiabatic ascent: modification of m
     623!computation of the sum of ascending fluxes
     624  IF (iflag_mix_adiab.eq.1) THEN
     625
     626!Verification sum(me)=sum(m)
     627  DO k = 1,nl+1
     628    DO il = 1, ncum
     629       md(il,k)=0.
     630       med(il,k)=0.
     631    ENDDO
     632  ENDDO
     633
     634  DO k = nl,1,-1
     635    DO il = 1, ncum
     636           md(il,k)=md(il,k+1)+m(il,k+1)
     637    ENDDO
     638  ENDDO
     639
     640  DO k = nl,1,-1
     641    DO il = 1, ncum
     642        IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN
     643           mad(il,k)=mad(il,k+1)+m(il,k+1)
     644        ENDIF
     645!        print*,"mad",il,k,mad(il,k)
     646    ENDDO
     647  ENDDO
     648
     649!CR: erosion of each adiabatic ascent during its ascent
     650
     651!Computation of erosion coefficient beta_coef
     652  DO k = 1, nl
     653    DO il = 1, ncum
     654       IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN     
     655!          print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1)
     656          beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2
     657       ELSE
     658          beta_coef(il,k)=0.
     659       ENDIF
     660    ENDDO
     661  ENDDO
     662
     663!  print*,"apres beta_coef"
     664
     665  DO k = 1, nl
     666    DO il = 1, ncum
     667
     668      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
     669
     670!        print*,"dz",il,k,tv(il, k-1)
     671        dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG)
     672        betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz)
     673!        betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz)
     674!        print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k)
     675        dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG)
     676!        me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k))
     677        me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k))
     678!        print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz   
     679     
     680      END IF
     681       
     682!Modification of m
     683      m(il,k)=me(il,k)
     684    END DO
     685  END DO
     686 
     687!  DO il = 1, ncum
     688!     dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG)
     689!     m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) &
     690!                  /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il))
     691!     print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il))
     692!  ENDDO
     693
     694!Verification sum(me)=sum(m)
     695  DO k = nl,1,-1
     696    DO il = 1, ncum
     697           med(il,k)=med(il,k+1)+m(il,k+1)
     698!           print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k)
     699    ENDDO
     700  ENDDO
     701
     702
     703  ENDIF !(iflag_mix_adiab)
     704!RC
     705
     706
     707
    603708  ! c 3. Compute final cloud base mass flux and set iflag to 3 if
    604709  ! c    cloud base mass flux is exceedingly small and is decreasing (i.e. if

  • LMDZ5/branches/testing/libf/phylmd/cv3p2_closure.F90

    r2408 r2435  
    5959  REAL                                               :: deltap, fac, w, amu
    6060  REAL, DIMENSION (nloc, nd)                         :: rhodp               ! Factor such that m=rhodp*sig*w
     61  REAL                                               :: dz
    6162  REAL                                               :: pbmxup
    6263  REAL, DIMENSION (nloc, nd)                         :: dtmin, sigold
    6364  REAL, DIMENSION (nloc, nd)                         :: coefmix
     65  REAL, DIMENSION (nloc)                             :: dtminmax
    6466  REAL, DIMENSION (nloc)                             :: pzero, ptop2old
    6567  REAL, DIMENSION (nloc)                             :: cina, cinb
    … …  
    8486  REAL, DIMENSION (nloc)                             :: alp2                  ! Alp with offset
    8587
     88!CR: variables for new erosion of adiabiatic ascent
     89  REAL, DIMENSION (nloc, nd)                         :: mad, me, betalim, beta_coef
     90  REAL, DIMENSION (nloc, nd)                         :: med, md
     91  REAL                                               :: coef_peel
     92  PARAMETER (coef_peel=0.25)
     93
    8694  REAL                                               :: sigmax
    8795  PARAMETER (sigmax=0.1)
    … …  
    119127    END DO
    120128  END DO
     129
     130!CR: initializations for erosion of adiabatic ascent
     131  DO k = 1,nl
     132    DO il = 1, ncum
     133        mad(il,k)=0.
     134        me(il,k)=0.
     135        betalim(il,k)=1.
     136        wlim(il,k)=0.
     137    ENDDO
     138  ENDDO
    121139
    122140  ! -------------------------------------------------------
    … …  
    163181  ! -------------------------------------------------------------
    164182
     183!jyg<
     184  IF (ok_convstop) THEN
     185    DO k = 1, nl - 1
     186      DO il = 1, ncum
     187        IF (sig(il,nd)<1.5 .OR. sig(il,nd)>noconv_stop) THEN
     188          sig(il, k) = 0.0
     189          w0(il, k) = 0.0
     190        END IF
     191      END DO
     192    END DO
     193  ELSE
    165194  DO k = 1, nl - 1
    166195    DO il = 1, ncum
    … …  
    171200    END DO
    172201  END DO
     202  ENDIF  ! (ok_convstop)
     203!>jyg
    173204  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 400'
    174205
    … …  
    427458  DO il = 1, ncum
    428459    cape(il) = 0.0
     460    dtminmax(il) = -100.
    429461  END DO
    430462
    … …  
    447479    END DO
    448480  END DO
     481!jyg<
     482!  Store maximum of dtmin
     483!  C est pas terrible d avoir ce test sur Ale+Cin encore une fois ici.
     484!                      A REVOIR !
     485  DO k = 1, nl
     486    DO il = 1, ncum
     487      IF (k>=(icb(il)+1) .AND. k<=inb(il) .AND. ale(il)+cin(il)>0.) THEN
     488        dtminmax(il) = max(dtmin(il,k), dtminmax(il))
     489      ENDIF
     490    END DO
     491  END DO
     492!
     493!    prevent convection when ale+cin <= 0
     494  DO k = 1, nl
     495    DO il = 1, ncum
     496      IF (k>=(icb(il)+1) .AND. k<=inb(il)) THEN
     497        dtmin(il,k) = min(dtmin(il,k), dtminmax(il))
     498      ENDIF
     499    END DO
     500  END DO
     501!>jyg
    449502!
    450503  IF (prt_level >= 20) THEN
    451504    print *,'cv3p2_closure: dtmin ', (k, dtmin(igout,k), k=1,nl)
     505    print *,'cv3p2_closure: dtminmax ', dtminmax(igout)
    452506  ENDIF
    453507!
    … …  
    459513      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
    460514
     515        IF (iflag_mix_adiab.eq.1) THEN
     516!CR:computation of cape from LCL: keep flag or to modify in all cases?
     517        deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k))
     518        ELSE
    461519        deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k))
     520        ENDIF
    462521        cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1)
    463522        cape(il) = amax1(0.0, cape(il))
    … …  
    588647  END DO
    589648
     649!jyg<
     650  IF (OK_intermittent) THEN
     651    DO il = 1, ncum
     652      IF (cbmflim(il)>1.E-6) THEN
     653        cbmfalpb(il) = min(cbmfalp(il), (cbmfmax(il)-beta*cbmf0(il))/(1.-beta))
     654        ! print*,'cbmfalpb',cbmfalpb(il),cbmfmax(il)
     655      END IF
     656    END DO
     657  ELSE
     658!>jyg
    590659  DO il = 1, ncum
    591660    IF (cbmflim(il)>1.E-6) THEN
    … …  
    599668    END IF
    600669  END DO
     670  ENDIF  !(OK_intermittent)
    601671  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmfalpb: cbmfalpb ',cbmfalpb(igout)
    602672
    … …  
    633703                         (k,w0(igout,k),sig(igout,k), k=icb(igout),inb(igout))
    634704
     705!CR: new erosion of adiabatic ascent: modification of m
     706!computation of the sum of ascending fluxes
     707  IF (iflag_mix_adiab.eq.1) THEN
     708
     709!Verification sum(me)=sum(m)
     710  DO k = 1,nl+1
     711    DO il = 1, ncum
     712       md(il,k)=0.
     713       med(il,k)=0.
     714    ENDDO
     715  ENDDO
     716
     717  DO k = nl,1,-1
     718    DO il = 1, ncum
     719           md(il,k)=md(il,k+1)+m(il,k+1)
     720    ENDDO
     721  ENDDO
     722
     723  DO k = nl,1,-1
     724    DO il = 1, ncum
     725        IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN
     726           mad(il,k)=mad(il,k+1)+m(il,k+1)
     727        ENDIF
     728!        print*,"mad",il,k,mad(il,k)
     729    ENDDO
     730  ENDDO
     731
     732!CR: erosion of each adiabatic ascent during its ascent
     733
     734!Computation of erosion coefficient beta_coef
     735  DO k = 1, nl
     736    DO il = 1, ncum
     737       IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN     
     738!          print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1)
     739          beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2
     740       ELSE
     741          beta_coef(il,k)=0.
     742       ENDIF
     743    ENDDO
     744  ENDDO
     745
     746!  print*,"apres beta_coef"
     747
     748  DO k = 1, nl
     749    DO il = 1, ncum
     750
     751      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
     752
     753!        print*,"dz",il,k,tv(il, k-1)
     754        dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG)
     755        betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz)
     756!        betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz)
     757!        print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k)
     758        dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG)
     759!        me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k))
     760        me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k))
     761!        print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz   
     762     
     763      END IF
     764       
     765!Modification of m
     766      m(il,k)=me(il,k)
     767    END DO
     768  END DO
     769 
     770!  DO il = 1, ncum
     771!     dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG)
     772!     m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) &
     773!                  /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il))
     774!     print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il))
     775!  ENDDO
     776
     777!Verification sum(me)=sum(m)
     778  DO k = nl,1,-1
     779    DO il = 1, ncum
     780           med(il,k)=med(il,k+1)+m(il,k+1)
     781!           print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k)
     782    ENDDO
     783  ENDDO
     784
     785
     786  ENDIF !(iflag_mix_adiab)
     787!RC
     788
    635789  ! c 3. Compute final cloud base mass flux;
    636790  ! c    set iflag to 3 if cloud base mass flux is exceedingly small and is
    637791  ! c     decreasing (i.e. if the final mass flux (cbmflast) is greater than
    638792  ! c     the target mass flux (cbmfalpb)).
     793  ! c    If(ok_convstop): set iflag to 4 if no positive buoyancy has been met
    639794
    640795!jyg  DO il = 1, ncum
    … …  
    658813  END DO
    659814
     815!jyg<
     816  IF (ok_convstop) THEN
     817    DO il = 1, ncum
     818      IF (dtminmax(il) .LE. 0.) THEN
     819        iflag(il) = 4
     820      END IF
     821    END DO
     822  ELSE
     823!>jyg
    660824  DO k = 1, nl
    661825    DO il = 1, ncum
    … …  
    667831    END DO
    668832  END DO
     833  ENDIF ! (ok_convstop)
    669834!
    670835  IF (prt_level >= 10) THEN

  • LMDZ5/branches/testing/libf/phylmd/cv3p_mixing.F90

    r2408 r2435  
    11SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
    2                        ph, t, rr, rs, u, v, tra, h, lv, qnk, &
     2                       ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, &
    33                       unk, vnk, hp, tv, tvp, ep, clw, sig, &
    44                       Ment, Qent, hent, uent, vent, nent, &
    … …  
    2020  include "cv3param.h"
    2121  include "YOMCST2.h"
     22  include "cvflag.h"
    2223
    2324!inputs:
    … …  
    3233  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra ! input of convect3
    3334  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv
     35  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
     36  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac !ice fraction in condensate
    3437  REAL, DIMENSION (nloc, na), INTENT (IN)            :: h  !liquid water static energy of environment
    3538  REAL, DIMENSION (nloc, na), INTENT (IN)            :: hp !liquid water static energy of air shed from adiab. asc.
    … …  
    5154  INTEGER i, j, k, il, im, jm
    5255  INTEGER num1, num2
    53   REAL                               :: rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
     56  REAL                               :: rti, bf2, anum, denom, dei, altem, cwat, stemp
    5457  REAL                               :: alt, delp, delm
    5558  REAL, DIMENSION (nloc)             :: Qmixmax, Rmixmax, sqmrmax
    … …  
    6063  REAL, DIMENSION (nloc)             :: Smid, Sjmin, Sjmax
    6164  REAL, DIMENSION (nloc)             :: Sbef, sup, smin
    62 !jyg  REAL, DIMENSION (nloc)             :: ASij, smax, Scrit
    6365  REAL, DIMENSION (nloc)             :: ASij, ASij_inv, smax, Scrit
    6466  REAL, DIMENSION (nloc, nd, nd)     :: Sij
    6567  REAL, DIMENSION (nloc, nd)         :: csum
    6668  REAL                               :: awat
     69  REAL                               :: cpm        !Mixed draught heat capacity
     70  REAL                               :: Tm         !Mixed draught temperature
    6771  LOGICAL, DIMENSION (nloc)          :: lwork
    6872
    … …  
    165169          rti = qnk(il) - ep(il, i)*clw(il, i)
    166170          bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
     171!jyg(from aj)<
     172          IF (cvflag_ice) THEN
     173! print*,cvflag_ice,'cvflag_ice dans do 700'
     174            IF (t(il,j)<=263.15) THEN
     175              bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* &
     176                   lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
     177            END IF
     178          END IF
     179!>jyg
    167180          anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
    168181          denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
    … …  
    176189          stemp = Sij(il, i, j)
    177190          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
    178             anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
    179             denom = denom + lv(il, j)*(rr(il,i)-rti)
     191!jyg(from aj)<
     192            IF (cvflag_ice) THEN
     193              anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2)
     194              denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti)
     195            ELSE
     196              anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
     197              denom = denom + lv(il, j)*(rr(il,i)-rti)
     198            END IF
     199!>jyg
    180200            IF (abs(denom)<0.01) denom = 0.01
    181201            Sij(il, i, j) = anum/denom
    … …  
    299319        lwork(il) = (nent(il,i)/=0)
    300320        rti = qnk(il) - ep(il, i)*clw(il, i)
    301         anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + &
    302                (cpv-cpd)*t(il, i)*(rti-rr(il,i))
    303         denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + &
    304                 (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
     321!jyg<
     322        IF (cvflag_ice) THEN
     323
     324          anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* &
     325                       (rti-rs(il,i)) + (cpv-cpd)*t(il, i)*(rti-rr(il,i))
     326          denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* &
     327                       (rr(il,i)-rti) + (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
     328        ELSE
     329
     330          anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + &
     331                       (cpv-cpd)*t(il, i)*(rti-rr(il,i))
     332          denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + &
     333                       (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
     334        END IF
     335!>jyg
    305336        IF (abs(denom)<0.01) denom = 0.01
    306337        Scrit(il) = min(anum/denom, 1.)
    … …  
    452483            hent(il, i, j) = (1.-Sigij(il,i,j))*hp(il, i) + Sigij(il, i, j)*h(il, i)
    453484
     485!jyg<
     486!            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
     487!            elij(il, i, j) = elij(il, i, j) + &
     488!                             ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / &
     489!                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
     490!            elij(il, i, j) = elij(il, i, j) / &
     491!                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
     492!                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
     493!
     494!       Computation of condensate amount Elij, taking into account the ice fraction frac
     495!       Warning : the same saturation humidity rs is used over both liquid water and ice; this
     496!                 should be corrected.
     497!
     498!  Heat capacity of mixed draught
     499    cpm = cpd+Qent(il,i,j)*(cpv-cpd)
     500!
     501    IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN
    454502            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
    455503            elij(il, i, j) = elij(il, i, j) + &
    456                              ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / &
    457                               ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
     504                             (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* &
     505                             rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j))
     506            elij(il, i, j) = elij(il, i, j) / &
     507                             (1.+(lv(il,j)+frac(il,j)*lf(il,j))*lv(il,j)*rs(il,j) / &
     508                              (cpm*rrv*t(il,j)*t(il,j)))
     509    ELSE
     510            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
     511            elij(il, i, j) = elij(il, i, j) + &
     512                             (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* &
     513                             rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j))
    458514            elij(il, i, j) = elij(il, i, j) / &
    459515                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
    460                               ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
    461 
     516                              (cpm*rrv*t(il,j)*t(il,j)))
     517    ENDIF
     518!>jyg
    462519            elij(il, i, j) = max(elij(il,i,j), 0.)
    463520
    … …  
    474531! :         t(il,j))
    475532
    476             hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat
     533!jyg<
     534!            hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat
     535! Mixed draught temperature at level j
     536    IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN
     537          Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j))
     538          hent(il, i, j) = hent(il, i, j) + (lv(il,j)+frac(il,j)*lf(il,j)+(cpd-cpv)*Tm)*awat
     539    ELSE
     540          Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j))
     541          hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*Tm)*awat
     542    ENDIF
     543!>jyg
     544
    477545!IM 301008 end
    478546

  • LMDZ5/branches/testing/libf/phylmd/cv3param.h

    r2298 r2435  
    77!------------------------------------------------------------
    88
     9      logical ok_convstop
     10      logical ok_intermittent
    911      integer noff, minorig, nl, nlp, nlm
    1012      real sigdz, spfac
    … …  
    1517      real dtovsh, dpbase, dttrig
    1618      real dtcrit, tau, beta, alpha, alpha1
     19      real tau_stop, noconv_stop
    1720      real wbmax
    1821      real delta
    … …  
    2528                      ,dtovsh, dpbase, dttrig &
    2629                      ,dtcrit, tau, beta, alpha, alpha1 &
     30                      ,tau_stop, noconv_stop &
    2731                      ,wbmax &
    2832                      ,delta, betad  &
    2933                      ,flag_epKEorig &
    3034                      ,flag_wb &
    31                       ,noff, minorig, nl, nlp, nlm
     35                      ,noff, minorig, nl, nlp, nlm  &
     36                      ,ok_convstop, ok_intermittent
    3237!$OMP THREADPRIVATE(/cv3param/)
    3338

  • LMDZ5/branches/testing/libf/phylmd/cva_driver.F90

    r2408 r2435  
    622622  END DO
    623623
     624!!  IF (iflag_con==3) THEN
     625!!    DO il = 1, len
     626!!      sig1(il, nd) = sig1(il, nd) + 1.
     627!!      sig1(il, nd) = amin1(sig1(il,nd), 12.1)
     628!!    END DO
     629!!  END IF
     630
    624631  IF (iflag_con==3) THEN
    625     DO il = 1, len
    626       sig1(il, nd) = sig1(il, nd) + 1.
    627       sig1(il, nd) = amin1(sig1(il,nd), 12.1)
    628     END DO
    629   END IF
     632      CALL cv3_incrcount(len,nd,delt,sig1)
     633  END IF  ! (iflag_con==3)
    630634
    631635! RomP >>>
    … …  
    876880      CALL cv3_undilute2(nloc, ncum, nd, icb, icbs, nk, &              !na->nd
    877881                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
    878                          p, h, tv, lv, lf, pbase, buoybase, plcl, &
     882                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
    879883                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
    880884                         frac)
    … …  
    892896! -------------------------------------------------------------------
    893897    IF (iflag_con==3) THEN
    894       IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN
    895         WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, &
    896           '. Might as well stop here.'
    897         STOP
    898       END IF
     898!      IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN
     899!        WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, &
     900!          '. Might as well stop here.'
     901!        STOP
     902!      END IF
    899903      IF (iflag_mix>=1) THEN
    900904        CALL zilch(supmax, nloc*klev)
    901905        CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &           ! na->nd
    902                          ph, t, q, qs, u, v, tra, h, lv, qnk, &
     906                         ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
    903907                         unk, vnk, hp, tv, tvp, ep, clw, sig, &
    904908                         ment, qent, hent, uent, vent, nent, &

  • LMDZ5/branches/testing/libf/phylmd/dyn1d/iniphysiq_mod.F90

    r2408 r2435  
    1 link ../../dynlonlat_phylonlat/phylmd/iniphysiq_mod.F90
     1link ../../dynphy_lonlat/phylmd/iniphysiq_mod.F90

  • LMDZ5/branches/testing/libf/phylmd/dyn1d/lmdz1d.F90

    r2408 r2435  
    1515       falb_dir, falb_dif, &
    1616       ftsol, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
    17        rlat, rlon, rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
     17       rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
    1818       solsw, t_ancien, q_ancien, u_ancien, v_ancien, wake_cstar, wake_deltaq, &
    1919       wake_deltat, wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
    … …  
    3636   USE iniphysiq_mod, ONLY: iniphysiq
    3737   USE mod_const_mpi, ONLY: comm_lmdz
     38   USE physiq_mod, ONLY: physiq
    3839
    3940      implicit none
    … …  
    219220      logical :: firstcall=.true.
    220221      logical :: lastcall=.false.
    221       real :: phis    = 0.0
    222       real :: dpsrf 
     222      real :: phis(1)    = 0.0
     223      real :: dpsrf(1)
    223224
    224225!---------------------------------------------------------------------
    … …  
    242243      integer :: k,l,i,it=1,mxcalc
    243244      integer jcode
    244       integer jjmp1
    245       parameter (jjmp1=jjm+1-1/jjm)
    246       REAL dudyn(iim+1,jjmp1,llm)
    247245      INTEGER read_climoz
    248246!Al1
    … …  
    559557      qsol = qsolinp
    560558      qsurf = fq_sat(tsurf,psurf/100.)
    561       rlat=xlat
    562       rlon=xlon
    563559      day1= day_ini
    564560      time=daytime-day
    … …  
    655651      zcvfi=airefi
    656652!
    657       rlat_rad(1)=rlat(1)*rpi/180.
    658       rlon_rad(1)=rlon(1)*rpi/180.
     653      rlat_rad(1)=xlat*rpi/180.
     654      rlon_rad(1)=xlon*rpi/180.
    659655
    660656     ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
    … …  
    938934
    939935       call physiq(ngrid,llm, &
    940             firstcall,lastcall, day,time,timestep, &
     936            firstcall,lastcall,timestep, &
    941937            plev,play,phi,phis,presnivs, &
    942938            u,v, rot, temp,q,omega2, &
    943             du_phys,dv_phys,dt_phys,dq,dpsrf, &
    944             dudyn)
     939            du_phys,dv_phys,dt_phys,dq,dpsrf)
    945940        firstcall=.false.
    946941

  • LMDZ5/branches/testing/libf/phylmd/dyn1d/mod_interface_dyn_phys.F90

    r2408 r2435  
    1 link ../../dynlonlat_phylonlat/mod_interface_dyn_phys.F90
     1link ../../dynphy_lonlat/mod_interface_dyn_phys.F90

  • LMDZ5/branches/testing/libf/phylmd/fisrtilp.F90

    r2425 r2435  
    123123  PARAMETER (ztfondue=278.15)
    124124  REAL dzfice(klon)
     125  REAL zsolid
    125126  !
    126127  LOGICAL appel1er
    … …  
    938939     !               *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)                                   
    939940
     941!CR : on prend en compte l'effet Bergeron dans les flux de precipitation
     942           if ((iflag_bergeron.eq.1).and.(zt(i).LT.273.15)) then
     943              zsolid = zrfl(i)
     944              zifl(i) = zifl(i)+zrfl(i)
     945              zrfl(i) = 0.
     946              zt(i)=zt(i)+zsolid*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
     947                      *(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*zq(i))
     948           endif
     949!RC   
     950
    940951         ENDIF                     
    941952       ENDDO

  • LMDZ5/branches/testing/libf/phylmd/fisrtilp.h

    r2425 r2435  
    1515      INTEGER iflag_pdf
    1616      INTEGER iflag_fisrtilp_qsat
     17      INTEGER iflag_bergeron
    1718
    1819      common/comfisrtilp/                                               &
    … …  
    2627     &     ,reevap_ice                                                  &
    2728     &     ,iflag_fisrtilp_qsat                                         &
     29     &     ,iflag_bergeron                                              &
    2830     &     ,iflag_pdf       
    2931

  • LMDZ5/branches/testing/libf/phylmd/geo2atm.F90

    r2408 r2435  
    3737
    3838  ! Value at North Pole
    39   IF (is_north_pole) THEN
     39  IF (is_north_pole_dyn) THEN
    4040     pu(:, 1) = -px (1,1)
    4141     pv(:, 1) = -py (1,1)
    … …  
    4444 
    4545  ! Value at South Pole     
    46   IF (is_south_pole) THEN
     46  IF (is_south_pole_dyn) THEN
    4747     pu(:,jm) = -px (1,jm)
    4848     pv(:,jm) = -py (1,jm)

  • LMDZ5/branches/testing/libf/phylmd/hgardfou.F90

    r2408 r2435  
    22! $Id$
    33SUBROUTINE hgardfou(t, tsol, text,abortphy)
    4   USE dimphy
    5   USE phys_state_var_mod
    6   USE indice_sol_mod
     4  USE dimphy, ONLY: klon, klev
     5  USE phys_state_var_mod, ONLY: pctsrf
     6  USE geometry_mod, ONLY: longitude_deg, latitude_deg
     7  USE indice_sol_mod, ONLY: nbsrf
    78  USE print_control_mod, ONLY: lunout
    89  IMPLICIT NONE
    … …  
    5556      DO i = 1, jbad
    5657        WRITE (lunout, *) 'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =', &
    57           jadrs(i), k, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
    58           (pctsrf(jadrs(i),nsrf), nsrf=1, nbsrf)
     58          jadrs(i), k, zt(jadrs(i)), longitude_deg(jadrs(i)), &
     59          latitude_deg(jadrs(i)),(pctsrf(jadrs(i),nsrf), nsrf=1, nbsrf)
    5960      END DO
    6061    END IF
    … …  
    7576      DO i = 1, jbad
    7677        WRITE (lunout, *) 'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =', &
    77           jadrs(i), k, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
    78           (pctsrf(jadrs(i),nsrf), nsrf=1, nbsrf)
     78          jadrs(i), k, zt(jadrs(i)), longitude_deg(jadrs(i)), &
     79          latitude_deg(jadrs(i)), (pctsrf(jadrs(i),nsrf), nsrf=1, nbsrf)
    7980      END DO
    8081    END IF
    … …  
    101102        WRITE (lunout, *) &
    102103          'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic =', jadrs(i), &
    103           nsrf, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
    104           pctsrf(jadrs(i), nsrf)
     104          nsrf, zt(jadrs(i)), longitude_deg(jadrs(i)), &
     105          latitude_deg(jadrs(i)), pctsrf(jadrs(i), nsrf)
    105106      END DO
    106107    END IF
    … …  
    122123        WRITE (lunout, *) &
    123124          'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic =', jadrs(i), &
    124           nsrf, zt(jadrs(i)), rlon(jadrs(i)), rlat(jadrs(i)), &
    125           pctsrf(jadrs(i), nsrf)
     125          nsrf, zt(jadrs(i)), longitude_deg(jadrs(i)), &
     126          latitude_deg(jadrs(i)), pctsrf(jadrs(i), nsrf)
    126127      END DO
    127128    END IF

  • LMDZ5/branches/testing/libf/phylmd/ini_histday_seri.h

    r2408 r2435  
    1313         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
    1414!
    15          CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon,zx_lon)
     15         CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,longitude_deg,zx_lon)
    1616         DO i = 1, nbp_lon
    17             zx_lon(i,1) = rlon(i+1)
    18             zx_lon(i,nbp_lat) = rlon(i+1)
     17            zx_lon(i,1) = longitude_deg(i+1)
     18            zx_lon(i,nbp_lat) = longitude_deg(i+1)
    1919         ENDDO
    2020         DO ll=1,klev
    2121            znivsig(ll)=REAL(ll)
    2222         ENDDO
    23          CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat,zx_lat)
     23         CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,latitude_deg,zx_lat)
    2424!
    2525         imin_debut=1

  • LMDZ5/branches/testing/libf/phylmd/ini_paramLMDZ_phy.h

    r2408 r2435  
    11!IM    Implemente en modes sequentiel et parallele
    22
    3        CALL gather(rlat,rlat_glo)
     3       CALL gather(latitude_deg,rlat_glo)
    44       CALL bcast(rlat_glo)
    5        CALL gather(rlon,rlon_glo)
     5       CALL gather(longitude_deg,rlon_glo)
    66       CALL bcast(rlon_glo)
    77

  • LMDZ5/branches/testing/libf/phylmd/iophy.F90

    r2408 r2435  
    4444                                jj_nb, jj_begin, jj_end, ii_begin, ii_end, &
    4545                                mpi_size, mpi_rank, klon_mpi, &
    46                                 is_sequential, is_south_pole
     46                                is_sequential, is_south_pole_dyn
    4747  USE mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo
    4848  USE print_control_mod, ONLY: prt_level,lunout
    … …  
    144144      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
    145145      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
    146       write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole
     146      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn
    147147    endif
    148148
    … …  
    151151                            1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end,             &
    152152                            klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend,             &
    153                             io_lat, io_lon,is_south_pole,mpi_rank)
     153                            io_lat, io_lon,is_south_pole_dyn,mpi_rank)
    154154#endif
    155155!$OMP END MASTER

  • LMDZ5/branches/testing/libf/phylmd/oasis.F90

    r2408 r2435  
    342342   
    343343    istart=ii_begin
    344     IF (is_south_pole) THEN
     344    IF (is_south_pole_dyn) THEN
    345345       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
    346346    ELSE
    … …  
    408408
    409409    istart=ii_begin
    410     IF (is_south_pole) THEN
     410    IF (is_south_pole_dyn) THEN
    411411       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
    412412    ELSE
    … …  
    417417       wstart=istart
    418418       wend=iend
    419        IF (is_north_pole) wstart=istart+nbp_lon-1
    420        IF (is_south_pole) wend=iend-nbp_lon+1
     419       IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
     420       IF (is_south_pole_dyn) wend=iend-nbp_lon+1
    421421       
    422422       DO i = 1, maxsend

  • LMDZ5/branches/testing/libf/phylmd/pbl_surface_mod.F90

    r2408 r2435  
    17341734!          print*,"DEBUGTS",yts(knon/2),ylwdown(knon/2)
    17351735          CALL surf_land(itap, dtime, date0, jour, knon, ni,&
    1736                rlon, rlat, &
     1736               rlon, rlat, yrmu0, &
    17371737               debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, &
    17381738               yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&

  • LMDZ5/branches/testing/libf/phylmd/phyetat0.F90

    r2408 r2435  
    1414       falb_dir, falb_dif, &
    1515       ftsol, pbl_tke, pctsrf, q_ancien, radpas, radsol, rain_fall, ratqs, &
    16        rlat, rlon, rnebcon, rugoro, sig1, snow_fall, solaire_etat0, sollw, sollwdown, &
     16       rnebcon, rugoro, sig1, snow_fall, solaire_etat0, sollw, sollwdown, &
    1717       solsw, t_ancien, u_ancien, v_ancien, w01, wake_cstar, wake_deltaq, &
    1818       wake_deltat, wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
    … …  
    2020       zmax0, zmea, zpic, zsig, &
    2121       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl
     22  USE geometry_mod, ONLY : longitude_deg, latitude_deg
    2223  USE iostart, ONLY : close_startphy, get_field, get_var, open_startphy
    2324  USE infotrac_phy, only: nbtr, nqo, type_trac, tname, niadv
    … …  
    7172  CHARACTER*2 str2
    7273  LOGICAL :: found,phyetat0_get,phyetat0_srf
     74  REAL :: lon_startphy(klon), lat_startphy(klon)
    7375
    7476  ! FH1D
    … …  
    137139   CALL init_iteration(itau_phy)
    138140
    139   ! Lecture des latitudes (coordonnees):
    140 
    141   CALL get_field("latitude", rlat)
    142 
    143   ! Lecture des longitudes (coordonnees):
    144 
    145   CALL get_field("longitude", rlon)
     141  ! read latitudes and make a sanity check (because already known from dyn)
     142  CALL get_field("latitude",lat_startphy)
     143  DO i=1,klon
     144    IF (ABS(lat_startphy(i)-latitude_deg(i))>=1) THEN
     145      WRITE(*,*) "phyetat0: Error! Latitude discrepancy wrt startphy file:",&
     146                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
     147                 " latitude_deg(i)=",latitude_deg(i)
     148      ! This is presumably serious enough to abort run
     149      CALL abort_physic("phyetat0","discrepancy in latitudes!",1)
     150    ENDIF
     151    IF (ABS(lat_startphy(i)-latitude_deg(i))>=0.0001) THEN
     152      WRITE(*,*) "phyetat0: Warning! Latitude discrepancy wrt startphy file:",&
     153                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
     154                 " latitude_deg(i)=",latitude_deg(i)
     155    ENDIF
     156  ENDDO
     157
     158  ! read longitudes and make a sanity check (because already known from dyn)
     159  CALL get_field("longitude",lon_startphy)
     160  DO i=1,klon
     161    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
     162      WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
     163                 " i=",i," lon_startphy(i)=",lon_startphy(i),&
     164                 " longitude_deg(i)=",longitude_deg(i)
     165      ! This is presumably serious enough to abort run
     166      CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
     167    ENDIF
     168    IF (ABS(lon_startphy(i)-longitude_deg(i))>=0.0001) THEN
     169      WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
     170                 " i=",i," lon_startphy(i)=",lon_startphy(i),&
     171                 " longitude_deg(i)=",longitude_deg(i)
     172    ENDIF
     173  ENDDO
    146174
    147175  ! Lecture du masque terre mer
    … …  
    430458  ! Initialize module ocean_cpl_mod for the case of coupled ocean
    431459  IF ( type_ocean == 'couple' ) THEN
    432      CALL ocean_cpl_init(dtime, rlon, rlat)
     460     CALL ocean_cpl_init(dtime, longitude_deg, latitude_deg)
    433461  ENDIF
    434462
    435   CALL init_iophy_new(rlat, rlon)
     463  CALL init_iophy_new(latitude_deg, longitude_deg)
    436464
    437465  ! Initilialize module fonte_neige_mod     

  • LMDZ5/branches/testing/libf/phylmd/phys_cal_mod.F90

    r2408 r2435  
    5252  END SUBROUTINE  phys_cal_init
    5353
    54   SUBROUTINE phys_cal_update(jD_cur, jH_cur)
     54  SUBROUTINE phys_cal_update(julian_date)
    5555    ! This subroutine updates the module saved variables.
    5656
    5757    USE IOIPSL, only: ju2ymds, ymds2ju, ioget_mon_len, ioget_year_len
    58    
    59     REAL, INTENT(IN) :: jD_cur ! jour courant a l'appel de la physique (jour julien)
    60     REAL, INTENT(IN) :: jH_cur ! heure courante a l'appel de la physique (jour julien)
     58    IMPLICIT NONE
     59    REAL, INTENT(IN) :: julian_date
     60
     61    jD_cur=INT(julian_date)
     62    jH_cur=julian_date-jD_cur
    6163   
    6264    CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour)
    … …  
    6870    days_elapsed = jD_cur - jD_1jan
    6971
    70     ! Get lenght of acutual month
     72    ! Get lenght of current month
    7173    mth_len = ioget_mon_len(year_cur,mth_cur)
    7274
     75    ! Get length of current year
    7376    year_len = ioget_year_len(year_cur)
    7477

  • LMDZ5/branches/testing/libf/phylmd/phys_output_write_mod.F90

    r2408 r2435  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44MODULE phys_output_write_mod
    … …  
    2525
    2626    USE dimphy, only: klon, klev, klevp1, nslay
     27    USE mod_phys_lmdz_para, ONLY: is_north_pole_phy,is_south_pole_phy
    2728    USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
    2829    USE time_phylmdz_mod, only: day_step_phy, start_time, itau_phy
    … …  
    348349!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    349350       CALL histwrite_phy(o_phis, pphis)
    350        CALL histwrite_phy(o_aire, cell_area)
     351
     352       zx_tmp_fi2d = cell_area
     353       if (is_north_pole_phy) then
     354         zx_tmp_fi2d(1) = cell_area(1)/nbp_lon
     355       endif
     356       if (is_south_pole_phy) then
     357         zx_tmp_fi2d(klon) = cell_area(klon)/nbp_lon
     358       endif
     359       CALL histwrite_phy(o_aire, zx_tmp_fi2d)
    351360
    352361       IF (vars_defined) THEN

  • LMDZ5/branches/testing/libf/phylmd/phys_state_var_mod.F90

    r2408 r2435  
    2222!$OMP THREADPRIVATE(dtime, solaire_etat0)
    2323
    24       REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:), pctsrf(:,:)
    25 !$OMP THREADPRIVATE(rlat, rlon, pctsrf)
     24      REAL, ALLOCATABLE, SAVE :: pctsrf(:,:)
     25!$OMP THREADPRIVATE(pctsrf)
    2626      REAL, ALLOCATABLE, SAVE :: ftsol(:,:)
    2727!$OMP THREADPRIVATE(ftsol)
    … …  
    420420
    421421include "clesphys.h"
    422       ALLOCATE(rlat(klon), rlon(klon))
     422
    423423      ALLOCATE(pctsrf(klon,nbsrf))
    424424      ALLOCATE(ftsol(klon,nbsrf))
    … …  
    590590!======================================================================
    591591SUBROUTINE phys_state_var_end
    592 USE dimphy
     592!USE dimphy
    593593USE indice_sol_mod
    594594IMPLICIT NONE
    595595include "clesphys.h"
    596596
    597       deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2)
     597      deallocate(pctsrf, ftsol, falb1, falb2)
    598598      deallocate(qsol,fevap,z0m,z0h,agesno)
    599599      deallocate(rain_fall, snow_fall, solsw, sollw, radsol, swradcorr)

  • LMDZ5/branches/testing/libf/phylmd/print_debug_phys.F90

    r1910 r2435  
    11SUBROUTINE print_debug_phys (i,debug_lev,text)
    22
    3 use dimphy
    4 use phys_local_var_mod
    5 use phys_state_var_mod
     3USE dimphy, ONLY: klev
     4USE phys_local_var_mod, ONLY: u_seri, v_seri, t_seri, q_seri, ql_seri
     5USE geometry_mod, ONLY: longitude_deg, latitude_deg
    66IMPLICIT NONE
    77integer i,debug_lev
    … …  
    1414print*,'l    u, v, T, q, ql'
    1515DO k = 1, klev
    16    write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,rlon(i),rlat(i),u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k)
     16   write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,longitude_deg(i),latitude_deg(i), &
     17   u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k)
    1718ENDDO
    1819

  • LMDZ5/branches/testing/libf/phylmd/radlwsw_m.F90

    r2408 r2435  
    426426
    427427!albedo SB >>>
    428 !      PALBD(i,1) = alb1(iof+i)
    429 !      PALBD(i,2) = alb2(iof+i)
    430 !         PALBD_NEW(i,1) = alb1(iof+i)   !!!!! A REVOIR (MPL) PALBD_NEW en
    431 !         fonction bdes SW
    432 !         do kk=2,NSW
    433 !           PALBD_NEW(i,kk) = alb2(iof+i)
    434 !         enddo
    435 !      PALBP(i,1) = alb1(iof+i)
    436 !      PALBP(i,2) = alb2(iof+i)
    437 !
    438 !         PALBP_NEW(i,1) = alb1(iof+i)     !!!!! A REVOIR (MPL) PALBP_NEW en
    439 !         fonction bdes SW
    440 !         do kk=2,NSW
    441 !           PALBP_NEW(i,kk) = alb2(iof+i)
    442 !         enddo
    443 
    444       if(iflag_rrtm==0)then
    445         select case(nsw)
    446         case(2)
    447           PALBD(i,1)=alb_dif(iof+i,1)
    448           PALBD(i,2)=alb_dif(iof+i,2)
    449           PALBP(i,1)=alb_dir(iof+i,1)
    450           PALBP(i,2)=alb_dir(iof+i,2)
    451         case(4)
    452           PALBD(i,1)=alb_dif(iof+i,1)
    453           PALBD(i,2)=(alb_dif(iof+i,2)*SFRWL(2)+alb_dif(iof+i,3)*SFRWL(3) &
    454                  +alb_dif(iof+i,4)*SFRWL(4))/(SFRWL(2)+SFRWL(3)+SFRWL(4))
    455           PALBP(i,1)=alb_dir(iof+i,1)
    456           PALBP(i,2)=(alb_dir(iof+i,2)*SFRWL(2)+alb_dir(iof+i,3)*SFRWL(3) &
    457                  +alb_dir(iof+i,4)*SFRWL(4))/(SFRWL(2)+SFRWL(3)+SFRWL(4))
    458         case(6)
    459           PALBD(i,1)=(alb_dif(iof+i,1)*SFRWL(1)+alb_dif(iof+i,2)*SFRWL(2) &
    460                  +alb_dif(iof+i,3)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3))
    461           PALBD(i,2)=(alb_dif(iof+i,4)*SFRWL(4)+alb_dif(iof+i,5)*SFRWL(5) &
    462                  +alb_dif(iof+i,6)*SFRWL(6))/(SFRWL(4)+SFRWL(5)+SFRWL(6))
    463           PALBP(i,1)=(alb_dir(iof+i,1)*SFRWL(1)+alb_dir(iof+i,2)*SFRWL(2)  &
    464                  +alb_dir(iof+i,3)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3))
    465           PALBP(i,2)=(alb_dir(iof+i,4)*SFRWL(4)+alb_dir(iof+i,5)*SFRWL(5)  &
    466                  +alb_dir(iof+i,6)*SFRWL(6))/(SFRWL(4)+SFRWL(5)+SFRWL(6))
    467         end select
    468       elseif(iflag_rrtm==1)then
     428!
     429      IF (iflag_rrtm==0) THEN
     430!
     431        PALBD(i,1)=alb_dif(iof+i,1)
     432        PALBD(i,2)=alb_dif(iof+i,2)
     433        PALBP(i,1)=alb_dir(iof+i,1)
     434        PALBP(i,2)=alb_dir(iof+i,2)
     435!
     436      ELSEIF (iflag_rrtm==1) THEn
     437!
    469438        DO kk=1,NSW
    470          PALBD_NEW(i,kk)=alb_dif(iof+i,kk)
    471          PALBP_NEW(i,kk)=alb_dir(iof+i,kk)
     439          PALBD_NEW(i,kk)=alb_dif(iof+i,kk)
     440          PALBP_NEW(i,kk)=alb_dir(iof+i,kk)
    472441        ENDDO
    473       endif
     442!
     443      ENDIF
    474444!albedo SB <<<
    475 
    476 
    477445
    478446
    … …  
    666634       ENDIF
    667635
    668              
    669           DO i=1,kdlon
    670           DO k=1,kflev+1
    671          ZSWFT0_i(1:klon,k) = ZFSDN0(1:klon,k)-ZFSUP0(1:klon,k)
    672          ZLWFT0_i(1:klon,k)=-ZFLDN0(1:klon,k)-ZFLUP0(1:klon,k)
     636       ZSWFT0_i(:,:) = ZFSDN0(:,:)-ZFSUP0(:,:)
     637       ZLWFT0_i(:,:) =-ZFLDN0(:,:)-ZFLUP0(:,:)
     638
     639       DO i=1,kdlon
     640       DO k=1,kflev+1
    673641!        print *,'iof i k klon klev=',iof,i,k,klon,klev
    674642         lwdn0 ( iof+i,k)   = ZFLDN0 ( i,k)
    … …  
    680648         swup0 ( iof+i,k)   = ZFSUP0 ( i,k)
    681649         swup  ( iof+i,k)   = ZFSUP  ( i,k)
    682           ENDDO 
    683           ENDDO 
     650       ENDDO 
     651       ENDDO 
    684652!          print*,'SW_AR4 ZFSDN0 1 , klev:',ZFSDN0(1:klon,1),ZFSDN0(1:klon,klev)
    685653!          print*,'SW_AR4 swdn0  1 , klev:',swdn0(1:klon,1),swdn0(1:klon,klev)

  • LMDZ5/branches/testing/libf/phylmd/rrtm/swni.F90

    r1999 r2435  
    419419        ZRRJ=ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK)
    420420        ZRRK=ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK)
    421         ZW2(JL,1) = LOG( ZRRJ ) * ZRR
    422         ZW2(JL,2) = LOG( ZRRK ) * ZRR
     421!        ZW2(JL,1) = LOG( ZRRJ ) * ZRR
     422!        ZW2(JL,2) = LOG( ZRRK ) * ZRR
     423!--correction Olivier Boucher based on ECMWF code
     424        ZW2(JL,1) = LOG( MAX(1.0_JPRB,ZRRJ) ) * ZRR
     425        ZW2(JL,2) = LOG( MAX(1.0_JPRB,ZRRK) ) * ZRR
    423426      ENDDO
    424427

  • LMDZ5/branches/testing/libf/phylmd/surf_land_mod.F90

    r2298 r2435  
    99! 
    1010  SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
    11        rlon, rlat, &
     11       rlon, rlat, yrmu0, &
    1212       debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, &
    1313       tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
    … …  
    4545    REAL, INTENT(IN)                        :: date0
    4646    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
     47    REAL, DIMENSION(klon), INTENT(IN)       :: yrmu0  ! cosine of solar zenith angle
    4748    LOGICAL, INTENT(IN)                     :: debut, lafin
    4849    REAL, INTENT(IN)                        :: dtime
    … …  
    132133       ! temporary for keeping same results using lwdown_m instead of lwdown
    133134       CALL surf_land_orchidee(itime, dtime, date0, knon, &
    134             knindex, rlon, rlat, pctsrf, &
     135            knindex, rlon, rlat, yrmu0, pctsrf, &
    135136            debut, lafin, &
    136137            zlev,  u1, v1, gustiness, temp_air, spechum, epot_air, ccanopy, &

  • LMDZ5/branches/testing/libf/phylmd/surf_land_orchidee_mod.F90

    r2408 r2435  
    33#ifndef ORCHIDEE_NOOPENMP
    44!
    5 ! This module controles the interface towards the model ORCHIDEE
     5! This module controles the interface towards the model ORCHIDEE.
     6!
     7! Compatibility with ORCHIDIEE :
     8! The current version can be used with ORCHIDEE/trunk from revision 2961.
     9! This interface can also be used with ORCHIDEE/trunk revision 1078-2960 if changing
     10! coszang=yrmu0 into sinang=yrmu0 at 2 places later below in this module.
    611!
    712! Subroutines in this module : surf_land_orchidee
    … …  
    3136! 
    3237  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
    33        knindex, rlon, rlat, pctsrf, &
     38       knindex, rlon, rlat, yrmu0, pctsrf, &
    3439       debut, lafin, &
    3540       plev,  u1_lay, v1_lay, gustiness, temp_air, spechum, epot_air, ccanopy, &
    … …  
    115120    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
    116121    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
     122    REAL, DIMENSION(klon), INTENT(IN)         :: yrmu0 ! cosine of solar zenith angle
    117123    REAL, DIMENSION(klon), INTENT(IN)         :: plev
    118124    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay, gustiness
    … …  
    405411               evap, fluxsens, fluxlat, coastalflow, riverflow, &
    406412               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
    407                lon_scat, lat_scat, q2m, t2m)
     413               lon_scat, lat_scat, q2m, t2m, coszang=yrmu0)
    408414#endif         
    409415       ENDIF
    … …  
    429435            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
    430436            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
    431             lon_scat, lat_scat, q2m, t2m)
     437            lon_scat, lat_scat, q2m, t2m, coszang=yrmu0(1:knon))
    432438#endif       
    433439    ENDIF

  • LMDZ5/branches/testing/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90

    r2408 r2435  
    55!
    66! This module is compiled only if CPP key ORCHIDEE_NOOPENMP is defined.
    7 ! This module should be used with ORCHIDEE sequentiel or parallele MPI version (not MPI-OpenMP mixte)
     7! This module should be used with ORCHIDEE sequentiel or parallele MPI version
     8! (not MPI-OpenMP mixte) until revision 1077 in the ORCHIDEE trunk.
    89
    910#ifdef ORCHIDEE_NOOPENMP
    … …  
    3536! 
    3637  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
    37        knindex, rlon, rlat, pctsrf, &
     38       knindex, rlon, rlat, yrmu0, pctsrf, &
    3839       debut, lafin, &
    3940       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, &
    … …  
    118119    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
    119120    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
     121    REAL, DIMENSION(klon), INTENT(IN)         :: yrmu0
    120122    REAL, DIMENSION(klon), INTENT(IN)         :: plev
    121123    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay

  • LMDZ5/branches/testing/libf/phylmd/surf_ocean_mod.F90

    r2408 r2435  
    175175
    176176!******************************************************************************
    177 ! Calculate albedo
     177! Calculate ocean surface albedo
    178178!******************************************************************************
    179179!albedo SB >>>
    180   if(iflag_albedo==1)then
    181     call ocean_albedo(knon,rmu0,knindex,windsp,SFRWL,alb_dir_new,alb_dif_new)
    182   else
     180IF (iflag_albedo==0) THEN
     181!--old parametrizations of ocean surface albedo
     182!
    183183    IF (cycle_diurne) THEN
     184!
    184185       CALL alboc_cd(rmu0,alb_eau)
     186!
     187!--ad-hoc correction for model radiative balance tuning
     188!--now outside alboc_cd routine
     189       alb_eau(:) = fmagic*alb_eau(:) + pmagic
     190       alb_eau=MIN(MAX(alb_eau,0.0),1.0)
     191!
    185192    ELSE
     193!
    186194       CALL alboc(REAL(jour),rlat,alb_eau)
     195!--ad-hoc correction for model radiative balance tuning
     196!--now outside alboc routine
     197       alb_eau(:) = fmagic*alb_eau(:) + pmagic
     198       alb_eau=MIN(MAX(alb_eau(i),0.04),0.60)
     199!
    187200    ENDIF
    188 
     201!
    189202    DO i =1, knon
    190       do  k=1,nsw
     203      DO  k=1,nsw
    191204       alb_dir_new(i,k) = alb_eau(knindex(i))
    192       enddo
     205      ENDDO
    193206    ENDDO
    194      alb_dif_new=0.05 !alb_dir_new
    195 endif
    196 
     207!IM 09122015 next line corresponds to the old way of doing in LMDZ5A/IPSLCM5A versions
     208!albedo for diffuse radiation is taken the same as for direct radiation
     209     alb_dif_new=alb_dir_new
     210!IM 09122015 end
     211!
     212ELSE IF (iflag_albedo==1) THEN
     213!--new parametrization of ocean surface albedo by Sunghye Baek
     214!--albedo for direct and diffuse radiation are different
     215!
     216    CALL ocean_albedo(knon,rmu0,knindex,windsp,SFRWL,alb_dir_new,alb_dif_new)
     217!
     218!--ad-hoc correction for model radiative balance tuning
     219    alb_dir_new(:,:) = fmagic*alb_dir_new(:,:) + pmagic
     220    alb_dir_new=MIN(MAX(alb_dir_new,0.0),1.0)
     221    alb_dif_new=MIN(MAX(alb_dif_new,0.0),1.0)
     222!
     223ENDIF
    197224!albedo SB <<<
    198225

  • LMDZ5/branches/testing/libf/phylmd/thermcell_alim.F90

    r2408 r2435  
    3939   lalim(:)=1
    4040   alim_star_tot(:)=0.
    41 
    42    IF (ngrid==1) PRINT*,'NEW ALIM flag=',flag
    4341
    4442!-------------------------------------------------------------------------
    … …  
    8482      enddo
    8583
    86       do l=1,klev-1
     84      do l=klev-1,1,-1
    8785         do ig=1,ngrid
    8886            ztv_parcel=ztv(ig,1)+d_temp(ig)
    89             if (ztv_parcel<ztv(ig,l+1) .and. lalim(ig)==1 ) THEN
    90                 lalim(ig)=l
    91                 zi(ig)=zlay(ig,l)+(zlay(ig,l+1)-zlay(ig,l))/(ztv(ig,l+1)-ztv(ig,l))*(ztv_parcel-ztv(ig,l))
    92                 IF (zi(ig)<0.) STOP
    93             endif
     87            if (ztv_parcel<ztv(ig,l+1)) lalim(ig)=l
    9488         enddo
    9589      enddo
     90
     91      do ig=1,ngrid
     92         l=lalim(ig)
     93         IF (l==1) THEN
     94            zi(ig)=0.
     95         ELSE
     96            ztv_parcel=ztv(ig,1)+d_temp(ig)
     97            zi(ig)=zlay(ig,l)+(zlay(ig,l+1)-zlay(ig,l))/(ztv(ig,l+1)-ztv(ig,l))*(ztv_parcel-ztv(ig,l))
     98         ENDIF
     99      enddo
     100
    96101      zh(:)=zi(:)/2.
    97102      alim_star_tot(:)=0.
    … …  
    100105      do l=1,klev-1
    101106         do ig=1,ngrid
    102             if (zlev(ig,l+1)<=zh(ig)) THEN
     107            IF (zh(ig)==0.) THEN
     108               alim_star(ig,l)=0.
     109               lalim(ig)=1
     110            ELSE IF (zlev(ig,l+1)<=zh(ig)) THEN
    103111               alim_star(ig,l)=(falim(zh(ig),zlev(ig,l+1))-falim(zh(ig),zlev(ig,l)))/falim(zh(ig),zh(ig))
    104112               lalim(ig)=l
    … …  
    112120         alim_star_tot(:)=alim_star_tot(:)+alim_star(:,l)
    113121      ENDDO
    114       IF (ngrid==1) print*,'NEW ALIM CALCUL DE ZI ',alim_star_tot
     122      IF (ngrid==1) print*,'NEW ALIM CALCUL DE ZI ',alim_star_tot,lalim,zi,zh
    115123      alim_star_tot(:)=1.
    116124

  • LMDZ5/branches/testing/libf/phylmd/thermcell_plume.F90

    r2408 r2435  
    106106      REAL,SAVE :: mix0,mix0_omp=0.
    107107      INTEGER,SAVE :: thermals_flag_alim,thermals_flag_alim_omp=0
     108
     109!$OMP THREADPRIVATE(fact_epsilon, betalpha, afact, fact_shell)
     110!$OMP THREADPRIVATE(detr_min, entr_min, detr_q_coef, detr_q_power)
     111!$OMP THREADPRIVATE( mix0, thermals_flag_alim)
    108112
    109113      LOGICAL, SAVE :: first=.true.
    … …  
    144148     mix0=mix0_omp
    145149     thermals_flag_alim=thermals_flag_alim_omp
     150
    146151      first=.false.
    147152      ENDIF

  • LMDZ5/branches/testing/libf/phylmd/time_phylmdz_mod.F90

    r2408 r2435  
    7777  END SUBROUTINE init_iteration
    7878
     79  SUBROUTINE update_time(pdtphys_)
     80  ! This subroutine updates the module saved variables.
     81  USE ioipsl, ONLY : ymds2ju
     82  USE phys_cal_mod, ONLY: phys_cal_update
     83  USE print_control_mod, ONLY: lunout
     84  IMPLICIT NONE
     85    REAL,INTENT(IN) :: pdtphys_
     86    REAL            :: julian_date
     87   
     88    ! Check if the physics timestep has changed
     89    IF ( ABS( (pdtphys-pdtphys_) / ((pdtphys+pdtphys_)/2))> 10.*EPSILON(pdtphys_)) THEN
     90       WRITE(lunout,*) "WARNING ! Physics time step changes from a call to the next",pdtphys_,pdtphys
     91       WRITE(lunout,*) "Not sure the physics parametrizations can handle this..."
     92    ENDIF
     93    pdtphys=pdtphys_
     94   
     95    ! Update elapsed time since begining of run:
     96    current_time=current_time+pdtphys
     97
     98    ! Compute corresponding Julian date and update calendar
     99    CALL ymds2ju(annee_ref,1,day_ini,start_time+current_time,julian_date)
     100    CALL phys_cal_update(julian_date)
     101   
     102  END SUBROUTINE update_time
     103
    79104END MODULE time_phylmdz_mod     
    80105

  • LMDZ5/branches/testing/libf/phylmd/write_histday_seri.h

    r2408 r2435  
    5252                     zx_tmp_2d,nbp_lon*nbp_lat,ndex2d)
    5353!
    54 !IM 151004 BEG
    55       IF(1.EQ.0) THEN
    56 !
    57       DO k=1, klev
    58       DO i=1, klon
    59        zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i))
    60       ENDDO
    61       ENDDO
    62 !
    63       CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d,  &
    64            cell_area, paprs, moyglo)
    65       zx_tmp_fi2d(1:klon)=moyglo
    66 !
    67       CALL gr_fi_ecrit(1, klon,nbp_lon,nbp_lat, zx_tmp_fi2d,zx_tmp_2d)
    68       CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d, &
    69                      nbp_lon*nbp_lat,ndex2d)
    70 !
    71 ! friction torque
    72 !
    73       DO i=1, klon
    74        zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i))
    75       ENDDO
    76 !
    77       ok_msk=.FALSE.
    78       CALL moyglo_pondaire(klon, zx_tmp_fi2d, cell_area,  &
    79            ok_msk, msk, moyglo)
    80       zx_tmp_fi2d(1:klon)=moyglo
    81 !
    82       CALL gr_fi_ecrit(1, klon,nbp_lon,nbp_lat, zx_tmp_fi2d,zx_tmp_2d)
    83       CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d, &
    84                      nbp_lon*nbp_lat,ndex2d)
    85 !
    86 ! mountain torque
    87 !
    88 !IM 190504 BEG
    89       CALL gr_fi_dyn(1,klon,nbp_lon+1,nbp_lat,cell_area,airedyn)
    90       CALL gr_fi_dyn(klev+1,klon,nbp_lon+1,nbp_lat,paprs,padyn)
    91       CALL gr_fi_dyn(1,klon,nbp_lon+1,nbp_lat,rlat,rlatdyn)
    92       mountor=0.
    93       airetot=0.
    94       DO j = 1, nbp_lat
    95        DO i = 1, nbp_lon+1
    96         ij=i+(nbp_lon+1)*(j-1)
    97         zx_tmp(ij)=0.
    98         DO k = 1, klev
    99          zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)* &
    100                     (padyn(i,j,k+1)-padyn(i,j,k))/RG
    101          airetot=airetot+airedyn(i,j)
    102         ENDDO
    103 !IM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA*
    104         mountor=mountor+zx_tmp(ij)*RA* &
    105                  cos(pir* rlatdyn(i,j))
    106        ENDDO
    107       ENDDO
    108 !IM 151004 BEG
    109       IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev
    110 !IM 151004 END
    111 !IM 190504      mountor=mountor/(airetot*airetot)
    112       mountor=mountor/airetot
    113 !
    114 !IM 190504 END
    115       zx_tmp_2d(1:nbp_lon,1:nbp_lat)=mountor
    116       CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d, &
    117                      nbp_lon*nbp_lat,ndex2d)
    118 !
    119       ENDIF !(1.EQ.0) THEN
    12054!
    12155!
    122       CALL gr_fi_dyn(1,klon,nbp_lon+1,nbp_lat,cell_area,airedyn)
    12356      CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,cell_area,zx_tmp_2d)
    12457      airetot=0.
    125 !     DO j = 1, nbp_lat
    126 !      DO i = 1, nbp_lon+1
    127 !       ij=i+(nbp_lon+1)*(j-1)
    128 !       DO k = 1, klev
    129 !        airetot=airetot+airedyn(i,j)
    130 !        airetot=airetot+airedyn(i,j)
    131 !       ENDDO !k
    132 !      ENDDO !i
    133 !     ENDDO !j
    134 !
    13558      DO i=1, klon
    13659       airetot=airetot+cell_area(i)
Note: See TracChangeset for help on using the changeset viewer.