Juan 9/01/2014: add header MNH_LIC to all MNH/*.f* files
[MNH-git_open_source-lfs.git] / src / MNH / condsamp.f90
1 !MNH_LIC Copyright 1994-2013 CNRS, Meteo-France and Universite Paul Sabatier
2 !MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
3 !MNH_LIC version 1. See LICENCE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
4 !MNH_LIC for details. version 1.
5 !-----------------------------------------------------------------
6 !--------------- special set of characters for RCS information
7 !-----------------------------------------------------------------
8 ! $Source$ $Revision$ $Date$
9 !-----------------------------------------------------------------
10 !     ######spl
11      MODULE MODI_CONDSAMP
12 !    ################## 
13 !
14 INTERFACE
15 !
16       SUBROUTINE CONDSAMP (PSFSV, KLUOUT, KVERB, OCLOSE_OUT, &
17                          HFMFILE, HLUOUT)
18 IMPLICIT NONE
19 REAL, DIMENSION(:,:,:), INTENT(INOUT)   :: PSFSV ! surface flux of scalars
20 INTEGER, INTENT(IN)          :: KLUOUT     ! unit for output listing count
21 INTEGER, INTENT(IN)          :: KVERB      ! verbosity level
22 LOGICAL, INTENT(IN)          :: OCLOSE_OUT! conditional closure of the 
23                                                ! OUTPUT FM-file
24 CHARACTER(LEN=*), INTENT(IN) :: HFMFILE   ! Name of the output
25                                                   ! FM-file
26 CHARACTER(LEN=*), INTENT(IN) :: HLUOUT    ! Output-listing name for
27                                                   ! model n
28 !
29 END SUBROUTINE CONDSAMP
30 !
31 END INTERFACE
32 !
33 END MODULE MODI_CONDSAMP
34 !     ######spl
35       SUBROUTINE CONDSAMP (PSFSV, KLUOUT, KVERB, OCLOSE_OUT, &
36                          HFMFILE, HLUOUT)
37 !     ############################################################
38 !
39 !
40 !
41 !!****  *PASPOL* -
42 !!
43 !!    PURPOSE
44 !!    -------
45 !!****  The purpose of this routine is to release tracers for conditional
46 !!       samplings according to Couvreux et al. (2010)
47 !
48 !!**  METHOD
49 !!    ------
50 !!    
51 !!
52 !!
53 !!    REFERENCE
54 !!    ---------
55 !!
56 !!    AUTHOR
57 !!    ------
58 !!      F.Couvreux, C.Lac         * Meteo-France *
59 !!
60 !!    MODIFICATIONS
61 !!    -------------
62 !!
63 !! --------------------------------------------------------------------------
64 !       
65 !!    EXTERNAL
66 !!    --------
67 !!
68 USE MODD_PARAMETERS , ONLY : JPVEXT
69 USE MODD_NSV        , ONLY : NSV_CSBEG, NSV_CSEND, NSV_CS
70 USE MODD_CONF_n     , ONLY : LUSERC
71 USE MODD_FIELD_n    , ONLY : XSVT, XRT
72 USE MODD_GRID_n     , ONLY : XZHAT
73 USE MODD_DYN        , ONLY : XTSTEP_MODEL1
74 USE MODD_CONDSAMP
75 USE MODE_ll
76 !
77 !*      0. DECLARATIONS
78 !          ------------
79 !
80 IMPLICIT NONE
81 !
82 !
83 !*      0.1    declarations of arguments
84 !
85 REAL, DIMENSION(:,:,:), INTENT(INOUT)   :: PSFSV ! surface flux of scalars
86 INTEGER, INTENT(IN)          :: KLUOUT     ! unit for output listing count
87 INTEGER, INTENT(IN)          :: KVERB      ! verbosity level
88 LOGICAL, INTENT(IN)          :: OCLOSE_OUT! conditional closure of the 
89                                                ! OUTPUT FM-file
90 CHARACTER(LEN=*), INTENT(IN) :: HFMFILE   ! Name of the output
91                                                   ! FM-file
92 CHARACTER(LEN=*), INTENT(IN) :: HLUOUT    ! Output-listing name for
93                                                   ! model n
94 !
95 !*      0.2    declarations of local variables
96 !
97
98 INTEGER :: IIB,IIE,IJB,IJE, IKB, IKE
99 INTEGER :: IIU, IJU, IKU                      ! dimensional indexes
100 INTEGER :: JK,JSV,IBOT,ITOP ! Loop indice
101 INTEGER :: IINFO_ll       ! return code of parallel routine
102 REAL, DIMENSION(SIZE(XRT,1),SIZE(XRT,2),SIZE(XRT,3)) :: ZRT
103 !
104 !--------------------------------------------------------------------------------------
105 !
106 !
107 !*      0. Initialisation
108 !
109 !
110 CALL GET_DIM_EXT_ll('B',IIU,IJU)
111 IKU = SIZE(XRT,3)
112 IKB = 1 + JPVEXT
113 IKE = IKU - JPVEXT
114 CALL GET_INDICE_ll(IIB,IJB,IIE,IJE)
115 !
116 !
117 !
118 !
119 !*      1.  INITIALIZATION OF CONDITIONAL SAMPLING TRACERS
120 !           ----------------------------------------------
121 ! on veut initialiser le 1er traceur a la surface tout le temps
122 ! le 2E si cloud 100m en dessous de cloud base
123 ! le 3eme si cloud 100m au dessus de cloud top
124 !
125 IBOT=0
126 ITOP=0
127
128 IF (( NSV_CS >= 2) .AND.LUSERC .AND.  MAX_ll(XRT(:,:,:,2),IINFO_ll) > 1.E-6 )  THEN
129    ! calcul de la base et du sommet des nuages
130    ! on ne considere que l'eau liquide car que pour nuages de couche limite
131    DO JK=1,IKE
132     ZRT(:,:,:) = SPREAD(XRT(:,:,JK,2),3,IKU)
133     IF ((MAX_ll(ZRT(:,:,:),IINFO_ll) > 1.E-6).AND.(IBOT == 0)) IBOT=JK
134     IF ( MAX_ll(ZRT(:,:,:),IINFO_ll) > 1.E-6) ITOP=JK
135    END DO
136    IF (KVERB >= 10) THEN
137     WRITE(KLUOUT,'(A)') ' '
138     WRITE(KLUOUT,'(A,F7.1)') 'Base nuage  : ',XZHAT(IBOT)
139     WRITE(KLUOUT,'(A,F7.1)') 'Sommet nuage: ',XZHAT(ITOP)
140     WRITE(KLUOUT,'(A,I3.1)') 'JK Base   : ',IBOT
141     WRITE(KLUOUT,'(A,I3.1)') 'JK Sommet : ',ITOP
142    END IF
143    !
144 END IF
145
146 DO JSV=NSV_CSBEG, NSV_CSEND
147  !
148  IF (JSV== NSV_CSBEG ) THEN 
149   ! emission en surface
150   PSFSV(IIB:IIE,IJB:IJE,JSV) = 1.
151  ENDIF
152
153  IF ((JSV == NSV_CSBEG + 1 ).AND.(IBOT > 2)) THEN
154     ! emission XHEIGHT_BASE(m) below the base on XDEPTH_BASE(m)
155     !
156     DO JK=1,IKE
157      IF ((XZHAT(JK) > XZHAT(IBOT) - XHEIGHT_BASE - XDEPTH_BASE/2. ).AND. &
158          (XZHAT(JK) < XZHAT(IBOT) - XHEIGHT_BASE + XDEPTH_BASE/2. )) THEN
159          XSVT(IIB:IIE,IJB:IJE,JK,JSV) =  &
160            XSVT(IIB:IIE,IJB:IJE,JK,JSV)+1.  
161      END IF
162     END DO
163  END IF    
164
165  IF ((JSV == NSV_CSBEG + 2 ).AND.(ITOP > 2)) THEN
166     ! emission XHEIGHT_TOP(m) above the top on XDEPTH_TOP(m)
167     !
168     DO JK=1,IKE
169      IF ((XZHAT(JK) > XZHAT(ITOP) + XHEIGHT_TOP - XDEPTH_TOP/2. ).AND. &
170          (XZHAT(JK) < XZHAT(ITOP) + XHEIGHT_TOP + XDEPTH_TOP/2. )) THEN
171          XSVT(IIB:IIE,IJB:IJE,JK,JSV) = &
172            XSVT(IIB:IIE,IJB:IJE,JK,JSV)+1. 
173      END IF
174     END DO
175  END IF    !
176 !
177 END DO            
178          !
179 !
180 ! correction d'eventuelle concentration n├ęgative
181 WHERE (XSVT(:,:,:,NSV_CSBEG:NSV_CSEND) <0.0) &
182        XSVT(:,:,:,NSV_CSBEG:NSV_CSEND)=0.0
183 !
184 !
185 !  2: Radioactive decrease            
186 !
187 DO JSV=NSV_CSBEG, NSV_CSEND
188    XSVT(:,:,:,JSV) = XSVT(:,:,:,JSV) *         &
189            EXP(-1.*XTSTEP_MODEL1/XRADIO(JSV-NSV_CSBEG+1)) 
190 END DO
191 !-------------------------------------------------------------------------------
192 !
193 !-------------------------------------------------------------------------------
194 !
195 END SUBROUTINE CONDSAMP