source: lmdz_wrf/WRFV3/lmdz/calcul_simulISCCP.h @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 6.5 KB
Line 
1!c
2!c $Id: calcul_simulISCCP.h 1403 2010-07-01 09:02:53Z fairhead $
3!c
4!c on appelle le simulateur ISCCP toutes les 3h
5!c et on fait des sorties 1 fois par jour
6!c
7!c ATTENTION : le temps de calcul peut augmenter considerablement !
8!c =============================================================== c
9      DO n=1, napisccp
10!c
11      nbapp_isccp=30 !appel toutes les 15h
12!IM 170107      isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique
13      freqin_pdt(n)=ifreq_isccp(n)
14!c
15!IM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee
16!c
17      DO i=1, klon
18       sunlit(i)=1 
19       IF(rmu0(i).EQ.0.) sunlit(i)=0
20       nbsunlit(1,i,n)=REAL(sunlit(i))
21      ENDDO
22!c
23!IM calcul tau, emissivite nuages convectifs
24!c
25      convfra(:,:)=rnebcon(:,:)
26      convliq(:,:)=rnebcon(:,:)*clwcon(:,:)
27!c
28      CALL newmicro (paprs, pplay,ok_newmicro,                                       &
29       &            t_seri, convliq, convfra, dtau_c, dem_c,                         &
30       &            cldh_c, cldl_c, cldm_c, cldt_c, cldq_c,                          &
31       &            flwp_c, fiwp_c, flwc_c, fiwc_c,                                  &
32       &            ok_aie,                                                          &
33       &            mass_solu_aero, mass_solu_aero_pi,                               &
34       &            bl95_b0, bl95_b1,                                                &
35       &            cldtaupi, re, fl)
36!c
37!IM calcul tau, emissivite nuages startiformes
38!c
39      CALL newmicro (paprs, pplay,ok_newmicro,                                       &
40       &            t_seri, cldliq, cldfra, dtau_s, dem_s,                           &
41       &            cldh_s, cldl_s, cldm_s, cldt_s, cldq_s,                          &
42       &            flwp_s, fiwp_s, flwc_s, fiwc_s,                                  &
43       &            ok_aie,                                                          &
44       &            mass_solu_aero, mass_solu_aero_pi,                               &
45       &            bl95_b0, bl95_b1,                                                &
46       &            cldtaupi, re, fl)
47!c
48      cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
49!c
50!IM inversion des niveaux de pression ==> de haut en bas
51!c
52      CALL haut2bas(klon, klev, pplay, pfull)
53      CALL haut2bas(klon, klev, q_seri, qv)
54      CALL haut2bas(klon, klev, cldtot, cc)
55      CALL haut2bas(klon, klev, rnebcon, conv)
56      CALL haut2bas(klon, klev, dtau_s, dtau_sH2B)
57      CALL haut2bas(klon, klev, dtau_c, dtau_cH2B)
58      CALL haut2bas(klon, klev, t_seri, at)
59      CALL haut2bas(klon, klev, dem_s, dem_sH2B)
60      CALL haut2bas(klon, klev, dem_c, dem_cH2B)
61      CALL haut2bas(klon, klevp1, paprs, phalf)
62!c
63!IM: initialisation de seed
64!c
65        DO i=1, klon
66!c
67         aa=ABS(paprs(i,2)-NINT(paprs(i,2)))
68         seed_re(i,n)=1000.*aa+1.
69         seed(i,n)=NINT(seed_re(i,n))
70!c
71         IF(seed(i,n).LT.50) THEN
72!c          print*,'seed<50 avant i seed itap paprs',i,
73!c    .     seed(i,n),itap,paprs(i,2)
74           seed(i,n)=50+seed(i,n)+i+itap
75           seed_old(i,n)=seed(i,n)
76!c
77           IF(itap.GT.1) then
78            IF(seed(i,n).EQ.seed_old(i,n)) THEN
79             seed(i,n)=seed(i,n)+10
80             seed_old(i,n)=seed(i,n)
81            ENDIF
82           ENDIF
83!c
84!c          print*,'seed<50 apres i seed itap paprs',i,
85!c    .     seed(i,n),itap,paprs(i,2)
86!c
87          ELSE IF(seed(i,n).EQ.0) THEN
88           print*,'seed=0 i paprs aa seed_re',                                       &
89       &     i,paprs(i,2),aa,seed_re(i,n)
90           abort_message = ''
91           CALL abort_gcm (modname,abort_message,1)
92          ELSE IF(seed(i,n).LT.0) THEN
93           print*,'seed < 0, i seed itap paprs',i,                                   &
94       &     seed(i,n),itap,paprs(i,2)
95           abort_message = ''
96           CALL abort_gcm (modname,abort_message,1)
97          ENDIF
98!c
99        ENDDO
100!c     
101!IM: pas de debug, debugcol
102      debug=0
103      debugcol=0
104!c
105!IM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa)
106!c
107        DO k=1, klevm1
108        kp1=k+1
109!c       PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1)
110        if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN
111         DO i=1, klon
112          o500(i)=omega(i,k)*RDAY/100.
113!c         if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1)
114         ENDDO
115         GOTO 1000
116        endif
1171000  continue
118      ENDDO
119!c
120!IM recalcule les nuages vus par satellite, via le simulateur ISCCP
121!c
122      CALL ISCCP_CLOUD_TYPES(                                                        &
123       &     debug,                                                                  &
124       &     debugcol,                                                               &
125       &     klon,                                                                   &
126       &     sunlit,                                                                 &
127       &     klev,                                                                   &
128       &     ncol(n),                                                                &
129       &     seed(:,n),                                                              &
130       &     pfull,                                                                  &
131       &     phalf,                                                                  &
132       &     qv, cc, conv, dtau_sH2B, dtau_cH2B,                                     &
133       &     top_height,                                                             &
134       &     overlap,                                                                &
135       &     tautab,                                                                 &
136       &     invtau,                                                                 &
137       &     ztsol,                                                                  &
138       &     emsfc_lw,                                                               &
139       &     at, dem_sH2B, dem_cH2B,                                                 &
140       &     fq_isccp(:,:,:,n),                                                      &
141       &     totalcldarea(:,n),                                                      &
142       &     meanptop(:,n),                                                          &
143       &     meantaucld(:,n),                                                        &
144       &     boxtau(:,:,n),                                                          &
145       &     boxptop(:,:,n))
146!c
147      ENDDO !n=1, napisccp
148
Note: See TracBrowser for help on using the repository browser.