| 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 | cIM 170107 isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique |
|---|
| 13 | freqin_pdt(n)=ifreq_isccp(n) |
|---|
| 14 | c |
|---|
| 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 |
|---|
| 20 | nbsunlit(1,i,n)=REAL(sunlit(i)) |
|---|
| 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, |
|---|
| 33 | e mass_solu_aero, mass_solu_aero_pi, |
|---|
| 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, |
|---|
| 44 | e mass_solu_aero, mass_solu_aero_pi, |
|---|
| 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 |
|---|
| 63 | cIM: 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 | 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, |
|---|
| 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 | |
|---|
