source: LMDZ4/trunk/libf/phy_IPCC_AR4/calcul_simulISCCP.h @ 868

Last change on this file since 868 was 868, checked in by Laurent Fairhead, 17 years ago

Preparation du remplacement de la physique utilisee pour l'exercice IPCC_AR4
par la version de la physique avec thermique. On garde le repertoire phylmd
pour un petit moment pour que les utilisateurs ne soient pas trop perdus ...
phy_IPCC_AR4 = phylmd
LF

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.7 KB
Line 
1c
2c $Header$
3c
4c on appelle le simulateur ISCCP toutes les 3h
5c et on fait des sorties 1 fois par jour
6c
7c ATTENTION : le temps de calcul peut augmenter considerablement !
8c =============================================================== c
9      DO n=1, napisccp
10c
11      nbapp_isccp=30 !appel toutes les 15h
12cIM 170107      isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique
13      freqin_pdt(n)=ifreq_isccp(n)
14c
15cIM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee
16c
17      DO i=1, klon
18       sunlit(i)=1 
19       IF(rmu0(i).EQ.0.) sunlit(i)=0
20       nbsunlit(1,i,n)=FLOAT(sunlit(i))
21      ENDDO
22c
23cIM calcul tau, emissivite nuages convectifs
24c
25      convfra(:,:)=rnebcon(:,:)
26      convliq(:,:)=rnebcon(:,:)*clwcon(:,:)
27c
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     e            ok_aie,
33     e            sulfate, sulfate_pi,
34     e            bl95_b0, bl95_b1,
35     s            cldtaupi, re, fl)
36c
37cIM calcul tau, emissivite nuages startiformes
38c
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     e            ok_aie,
44     e            sulfate, sulfate_pi,
45     e            bl95_b0, bl95_b1,
46     s            cldtaupi, re, fl)
47c
48      cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
49c
50cIM inversion des niveaux de pression ==> de haut en bas
51c
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)
62c
63cIM lecture invtau, tautab des fichiers formattes
64c
65      IF (debut) THEN
66c$OMP MASTER
67c     open(99,file='tautab.bin',access='sequential',
68c    $     form='unformatted',status='old')
69c     read(99) tautab_omp
70c
71      open(99,file='tautab.formatted', FORM='FORMATTED')
72      read(99,'(f30.20)') tautab_omp
73      close(99)
74c
75      open(99,file='invtau.formatted',form='FORMATTED')
76      read(99,'(i10)') invtau_omp
77      close(99)
78c$OMP END MASTER
79c$OMP BARRIER
80      tautab=tautab_omp
81      invtau=invtau_omp
82c
83      ENDIF !debut
84c
85cIM: initialisation de seed
86c
87        DO i=1, klon
88c
89         aa=ABS(paprs(i,2)-NINT(paprs(i,2)))
90         seed_re(i,n)=1000.*aa+1.
91         seed(i,n)=NINT(seed_re(i,n))
92c
93         IF(seed(i,n).LT.50) THEN
94c          print*,'seed<50 avant i seed itap paprs',i,
95c    .     seed(i,n),itap,paprs(i,2)
96           seed(i,n)=50+seed(i,n)+i+itap
97           seed_old(i,n)=seed(i,n)
98c
99           IF(itap.GT.1) then
100            IF(seed(i,n).EQ.seed_old(i,n)) THEN
101             seed(i,n)=seed(i,n)+10
102             seed_old(i,n)=seed(i,n)
103            ENDIF
104           ENDIF
105c
106c          print*,'seed<50 apres i seed itap paprs',i,
107c    .     seed(i,n),itap,paprs(i,2)
108c
109          ELSE IF(seed(i,n).EQ.0) THEN
110           print*,'seed=0 i paprs aa seed_re',
111     .     i,paprs(i,2),aa,seed_re(i,n)
112           STOP
113          ELSE IF(seed(i,n).LT.0) THEN
114           print*,'seed < 0, i seed itap paprs',i,
115     .     seed(i,n),itap,paprs(i,2)
116           STOP
117          ENDIF
118c
119        ENDDO
120c     
121cIM: pas de debug, debugcol
122      debug=0
123      debugcol=0
124c
125cIM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa)
126c
127        DO k=1, klevm1
128        kp1=k+1
129c       PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1)
130        if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN
131         DO i=1, klon
132          o500(i)=omega(i,k)*RDAY/100.
133c         if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1)
134         ENDDO
135         GOTO 1000
136        endif
1371000  continue
138      ENDDO
139c
140cIM recalcule les nuages vus par satellite, via le simulateur ISCCP
141c
142      CALL ISCCP_CLOUD_TYPES(
143     &     debug,
144     &     debugcol,
145     &     klon,
146     &     sunlit,
147     &     klev,
148     &     ncol(n),
149     &     seed(:,n),
150     &     pfull,
151     &     phalf,
152     &     qv, cc, conv, dtau_sH2B, dtau_cH2B,
153     &     top_height,
154     &     overlap,
155     &     tautab,
156     &     invtau,
157     &     ztsol,
158     &     emsfc_lw,
159     &     at, dem_sH2B, dem_cH2B,
160     &     fq_isccp(:,:,:,n),
161     &     totalcldarea(:,n),
162     &     meanptop(:,n),
163     &     meantaucld(:,n),
164     &     boxtau(:,:,n),
165     &     boxptop(:,:,n))
166c
167      ENDDO !n=1, napisccp
168
Note: See TracBrowser for help on using the repository browser.