[644] | 1 | c |
---|
[1403] | 2 | c $Id: calcul_simulISCCP.h 1403 2010-07-01 09:02:53Z crisi $ |
---|
[644] | 3 | c |
---|
[684] | 4 | c on appelle le simulateur ISCCP toutes les 3h |
---|
| 5 | c et on fait des sorties 1 fois par jour |
---|
[644] | 6 | c |
---|
[684] | 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 |
---|
[827] | 12 | cIM 170107 isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique |
---|
[684] | 13 | freqin_pdt(n)=ifreq_isccp(n) |
---|
| 14 | c |
---|
[644] | 15 | cIM 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 |
---|
[1403] | 20 | nbsunlit(1,i,n)=REAL(sunlit(i)) |
---|
[644] | 21 | ENDDO |
---|
| 22 | c |
---|
| 23 | cIM 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 | e ok_aie, |
---|
[1279] | 33 | e mass_solu_aero, mass_solu_aero_pi, |
---|
[644] | 34 | e bl95_b0, bl95_b1, |
---|
| 35 | s cldtaupi, re, fl) |
---|
| 36 | c |
---|
| 37 | cIM 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 | e ok_aie, |
---|
[1279] | 44 | e mass_solu_aero, mass_solu_aero_pi, |
---|
[644] | 45 | e bl95_b0, bl95_b1, |
---|
| 46 | s cldtaupi, re, fl) |
---|
| 47 | c |
---|
| 48 | cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) |
---|
| 49 | c |
---|
| 50 | cIM 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 |
---|
[684] | 63 | cIM: initialisation de seed |
---|
[644] | 64 | c |
---|
[684] | 65 | DO i=1, klon |
---|
[644] | 66 | c |
---|
[684] | 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)) |
---|
[644] | 70 | c |
---|
[684] | 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) |
---|
[1403] | 90 | abort_message = '' |
---|
| 91 | CALL abort_gcm (modname,abort_message,1) |
---|
[684] | 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) |
---|
[1403] | 95 | abort_message = '' |
---|
| 96 | CALL abort_gcm (modname,abort_message,1) |
---|
[684] | 97 | ENDIF |
---|
| 98 | c |
---|
[644] | 99 | ENDDO |
---|
| 100 | c |
---|
| 101 | cIM: pas de debug, debugcol |
---|
| 102 | debug=0 |
---|
| 103 | debugcol=0 |
---|
| 104 | c |
---|
| 105 | cIM 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 |
---|
| 117 | 1000 continue |
---|
| 118 | ENDDO |
---|
| 119 | c |
---|
| 120 | cIM 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, |
---|
[684] | 128 | & ncol(n), |
---|
| 129 | & seed(:,n), |
---|
[644] | 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, |
---|
[684] | 140 | & fq_isccp(:,:,:,n), |
---|
| 141 | & totalcldarea(:,n), |
---|
| 142 | & meanptop(:,n), |
---|
| 143 | & meantaucld(:,n), |
---|
| 144 | & boxtau(:,:,n), |
---|
| 145 | & boxptop(:,:,n)) |
---|
[644] | 146 | c |
---|
[684] | 147 | ENDDO !n=1, napisccp |
---|
| 148 | |
---|