source: LMDZ6/branches/Amaury_dev/libf/phylmd/inlandsis/sisvat_zag.f90

Last change on this file was 5117, checked in by abarral, 2 months ago

rename modules properly lmdz_*
move some unused files to obsolete/
(lint) uppercase fortran keywords
File size: 11.0 KB
Line 
1
2
3SUBROUTINE SISVAT_zAg &
4        (isagra,isagrb,WEagra &
5        ,dzagra,dzagrb,T_agra,T_agrb &
6        ,roagra,roagrb,etagra,etagrb &
7        ,G1agra,G1agrb,G2agra,G2agrb &
8        ,agagra,agagrb,Agreg1 &
9        )
10
11  ! +------------------------------------------------------------------------+
12  ! | MAR SURFACE                                       Sat 30-Apr-2004  MAR |
13  ! |   SubRoutine SISVAT_zAg aggregates two contiguous snow layers          |
14  ! |                                                                        |
15  ! +------------------------------------------------------------------------+
16  ! |                                                                        |
17  ! |   PARAMETERS:  knonv: Total Number of columns =                        |
18  ! |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
19  ! |                     X       Number of Mosaic Cell per grid box         |
20  ! |                                                                        |
21  ! |   INPUT:   isagrb   : 2nd     Layer History                            |
22  ! |   ^^^^^                                                                |
23  ! |                                                                        |
24  ! |   INPUT:   dzagrb   : 2nd     Layer Thickness                          |
25  ! |   ^^^^^    T_agrb   : 2nd     Layer Temperature                        |
26  ! |            roagrb   : 2nd     Layer Density                            |
27  ! |            etagrb   : 2nd     Layer Water Content                      |
28  ! |            G1agrb   : 2nd     Layer Dendricity/Spher.                  |
29  ! |            G2agrb   : 2nd     Layer Sphericity/Size                    |
30  ! |            agagrb   : 2nd     Age                                      |
31  ! |            Agreg1   : 1. when Agregation constrained                   |
32  ! |                                                                        |
33  ! |   INPUT /  isagra   : 1st     Layer History                            |
34  ! |   OUTPUT:                                                              |
35  ! |   ^^^^^^                                                               |
36  ! |                                                                        |
37  ! |   INPUT /  dzagra   : 1st     Layer Thickness                          |
38  ! |   OUTPUT:  T_agra   : 1st     Layer Temperature                        |
39  ! |   ^^^^^^   roagra   : 1st     Layer Density                            |
40  ! |            etagra   : 1st     Layer Water Content                      |
41  ! |            G1agra   : 1st     Layer Dendricity/Spher.                  |
42  ! |            G2agra   : 1st     Layer Sphericity/Size                    |
43  ! |            agagra   : 1st     Age                                      |
44  ! |                                                                        |
45  ! +------------------------------------------------------------------------+
46
47
48
49
50  ! +--Global Variables
51  ! +  ================
52
53  USE VARphy
54  USE VAR_SV
55  USE VARdSV
56  USE VAR0SV
57  USE VARxSV
58
59  IMPLICIT NONE
60
61
62  ! +--INPUT
63  ! +  -----
64
65  INTEGER :: isagrb(knonv)                 ! 2nd Layer History
66  REAL :: dzagrb(knonv)                 ! 2nd Layer Thickness
67  REAL :: T_agrb(knonv)                 ! 2nd Layer Temperature
68  REAL :: roagrb(knonv)                 ! 2nd Layer Density
69  REAL :: etagrb(knonv)                 ! 2nd Layer Water Content
70  REAL :: G1agrb(knonv)                 ! 2nd Layer Dendricity/Spher.
71  REAL :: G2agrb(knonv)                 ! 2nd Layer Sphericity/Size
72  REAL :: agagrb(knonv)                 ! 2nd Layer Age
73
74
75  ! +--INPUT/OUTPUT
76  ! +  ------------
77
78  INTEGER :: isagra(knonv)                 ! 1st Layer History
79  REAL :: WEagra(knonv)                 ! 1st Layer Height    [mm w.e.]
80  REAL :: Agreg1(knonv)                 ! 1. ===>   Agregates
81  REAL :: dzagra(knonv)                 ! 1st Layer Thickness
82  REAL :: T_agra(knonv)                 ! 1st Layer Temperature
83  REAL :: roagra(knonv)                 ! 1st Layer Density
84  REAL :: etagra(knonv)                 ! 1st Layer Water Content
85  REAL :: G1agra(knonv)                 ! 1st Layer Dendricity/Spher.
86  REAL :: G2agra(knonv)                 ! 1st Layer Sphericity/Size
87  REAL :: agagra(knonv)                 ! 1st Layer Age
88
89
90  ! +--Internal Variables
91  ! +  ==================
92
93  INTEGER :: ikl
94  INTEGER :: nh                            ! Averaged    Snow History
95  INTEGER :: nh__OK                        ! 1=>Conserve Snow History
96  REAL :: rh                            !
97  REAL :: dz                            ! Thickness
98  REAL :: dzro_1                        ! Thickness X Density, Lay.1
99  REAL :: dzro_2                        ! Thickness X Density, Lay.2
100  REAL :: dzro                          ! Thickness X Density, Aver.
101  REAL :: ro                            ! Averaged    Density
102  REAL :: wn                            ! Averaged    Water Content
103  REAL :: tn                            ! Averaged    Temperature
104  REAL :: ag                            ! Averaged    Snow Age
105  REAL :: SameOK                        ! 1. => Same Type of Grains
106  REAL :: G1same                        ! Averaged G1,  same Grains
107  REAL :: G2same                        ! Averaged G2,  same Grains
108  REAL :: typ__1                        ! 1. => Lay1 Type: Dendritic
109  REAL :: zroNEW                        ! dz X ro, if fresh Snow
110  REAL :: G1_NEW                        ! G1,      if fresh Snow
111  REAL :: G2_NEW                        ! G2,      if fresh Snow
112  REAL :: zroOLD                        ! dz X ro, if old   Snow
113  REAL :: G1_OLD                        ! G1,      if old   Snow
114  REAL :: G2_OLD                        ! G2,      if old   Snow
115  REAL :: SizNEW                        ! Size,    if fresh Snow
116  REAL :: SphNEW                        ! Spheric.,if fresh Snow
117  REAL :: SizOLD                        ! Size,    if old   Snow
118  REAL :: SphOLD                        ! Spheric.,if old   Snow
119  REAL :: Siz_av                        ! Averaged    Grain Size
120  REAL :: Sph_av                        ! Averaged    Grain Spher.
121  REAL :: Den_av                        ! Averaged    Grain Dendr.
122  REAL :: DendOK                        ! 1. => Average is  Dendr.
123  REAL :: G1diff                        ! Averaged G1, diff. Grains
124  REAL :: G2diff                        ! Averaged G2, diff. Grains
125  REAL :: G1                            ! Averaged G1
126  REAL :: G2                            ! Averaged G2
127
128
129
130  ! +--Mean   Properties
131  ! +  =================
132
133  ! +-- 1 Densite, Contenu en Eau, Temperature /
134  ! +     Density, Water Content,  Temperature
135  ! +     ------------------------------------
136
137  DO ikl = 1,knonv
138      dz      =  dzagra(ikl) + dzagrb(ikl)
139      dzro_1  =  roagra(ikl) * dzagra(ikl)
140      dzro_2  =  roagrb(ikl) * dzagrb(ikl)
141      dzro    =  dzro_1      + dzro_2
142      ro      =  dzro &
143            /max(epsi,dz)
144      wn      = (dzro_1*etagra(ikl) + dzro_2*etagrb(ikl)) &
145            /max(epsi,dzro)
146      tn      = (dzro_1*T_agra(ikl) + dzro_2*T_agrb(ikl)) &
147            /max(epsi,dzro)
148      ag      = (dzro_1*agagra(ikl) + dzro_2*agagrb(ikl)) &
149            /max(epsi,dzro)
150
151      rh      =  max(zero,sign(unun,zWEcSV(ikl) &
152            -0.5*WEagra(ikl)))
153      nh__OK  =  rh
154      nh      =                 max(isagra(ikl),isagrb(ikl))
155  ! #HB.            *  nh__OK
156  ! #HB.          + (1-nh__OK)*       min(isagra(ikl),isagrb(ikl))
157
158
159
160  ! +-- 2 Nouveaux Types de Grains /  new Grain Types
161  ! +     -------------------------------------------
162
163  ! +-- 2.1. Meme  Type  de Neige  / same Grain Type
164  ! +        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
165      SameOK  =  max(zero, &
166            sign(unun, G1agra(ikl) *G1agrb(ikl)  - eps_21))
167      G1same  = (dzro_1*G1agra(ikl) + dzro_2*G1agrb(ikl)) &
168            /max(epsi,dzro)
169      G2same  = (dzro_1*G2agra(ikl) + dzro_2*G2agrb(ikl)) &
170            /max(epsi,dzro)
171
172  ! +-- 2.2. Types differents / differents Types
173  ! +        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
174      typ__1  =  max(zero,sign(unun,epsi-G1agra(ikl))) ! =1.=> Dendritic
175      zroNEW  =     typ__1  *dzro_1 & ! ro of Dendr.Lay.
176            + (1.-typ__1) *dzro_2                    !
177      G1_NEW  =     typ__1  *G1agra(ikl) & ! G1 of Dendr.Lay.
178            + (1.-typ__1) *G1agrb(ikl)               !
179      G2_NEW  =     typ__1  *G2agra(ikl) & ! G2 of Dendr.Lay.
180            + (1.-typ__1) *G2agrb(ikl)               !
181      zroOLD  = (1.-typ__1) *dzro_1 & ! ro of Spher.Lay.
182            +     typ__1  *dzro_2                    !
183      G1_OLD  = (1.-typ__1) *G1agra(ikl) & ! G1 of Spher.Lay.
184            +     typ__1  *G1agrb(ikl)               !
185      G2_OLD  = (1.-typ__1) *G2agra(ikl) & ! G2 of Spher.Lay.
186            +     typ__1  *G2agrb(ikl)               !
187      SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV & ! Size  Dendr.Lay.
188            +(1.+G1_NEW         /G1_dSV) & !
189            *(G2_NEW  *DScdSV/G1_dSV & !
190            +(1.-G2_NEW         /G1_dSV)*DFcdSV)    !
191      SphNEW  =     G2_NEW         /G1_dSV             ! Spher.Dendr.Lay.
192      SizOLD  =     G2_OLD                             ! Size  Spher.Lay.
193      SphOLD  =     G1_OLD         /G1_dSV             ! Spher.Spher.Lay.
194      Siz_av  = (zroNEW*SizNEW+zroOLD*SizOLD) & ! Averaged Size
195            /max(epsi,dzro)                             !
196      Sph_av  = (zroNEW*SphNEW+zroOLD*SphOLD) & ! Averaged Sphericity
197            /max(epsi,dzro)                             !
198      Den_av  = (Siz_av -(    Sph_av *DScdSV & !
199            +(1.-Sph_av)*DFcdSV)) & !
200            / (DDcdSV -(    Sph_av *DScdSV & !
201            +(1.-Sph_av)*DFcdSV))     !
202      DendOK  = max(zero, & !
203            sign(unun,     Sph_av *DScdSV & ! Small   Grains Contr.
204            +(1.-Sph_av)*DFcdSV & ! Faceted Grains Contr.
205            -    Siz_av        ))!
206  ! +...    REMARQUE: le  type moyen (dendritique ou non) depend
207  ! +       ^^^^^^^^  de la  comparaison avec le diametre optique
208  ! +                 d'une neige recente de   dendricite nulle
209  ! +...    REMARK:   the mean type  (dendritic   or not) depends
210  ! +       ^^^^^^    on the comparaison with the optical diameter
211  ! +                 of a recent snow    having zero dendricity
212
213      G1diff  =(   -DendOK *Den_av &
214            +(1.-DendOK)*Sph_av) *G1_dSV
215      G2diff  =     DendOK *Sph_av  *G1_dSV &
216            +(1.-DendOK)*Siz_av
217      G1      =     SameOK *G1same &
218            +(1.-SameOK)*G1diff
219      G2      =     SameOK *G2same &
220            +(1.-SameOK)*G2diff
221
222
223  ! +--Assignation to new Properties
224  ! +  =============================
225
226      isagra(ikl)   = Agreg1(ikl) *nh +(1.-Agreg1(ikl)) *isagra(ikl)
227      dzagra(ikl)   = Agreg1(ikl) *dz +(1.-Agreg1(ikl)) *dzagra(ikl)
228      T_agra(ikl)   = Agreg1(ikl) *tn +(1.-Agreg1(ikl)) *T_agra(ikl)
229      roagra(ikl)   = Agreg1(ikl) *ro +(1.-Agreg1(ikl)) *roagra(ikl)
230      etagra(ikl)   = Agreg1(ikl) *wn +(1.-Agreg1(ikl)) *etagra(ikl)
231      G1agra(ikl)   = Agreg1(ikl) *G1 +(1.-Agreg1(ikl)) *G1agra(ikl)
232      G2agra(ikl)   = Agreg1(ikl) *G2 +(1.-Agreg1(ikl)) *G2agra(ikl)
233      agagra(ikl)   = Agreg1(ikl) *ag +(1.-Agreg1(ikl)) *agagra(ikl)
234
235  END DO
236
237
238END SUBROUTINE sisvat_zag
Note: See TracBrowser for help on using the repository browser.