[3] | 1 | SUBROUTINE OPTCI(ykim,nmicro,IPRINT) |
---|
| 2 | #include "dimensions.h" |
---|
| 3 | #include "dimphy.h" |
---|
| 4 | #include "microtab.h" |
---|
| 5 | #include "numchimrad.h" |
---|
| 6 | #include "clesphys.h" |
---|
| 7 | |
---|
| 8 | c Arguments: |
---|
| 9 | c --------- |
---|
| 10 | REAL ykim(klon,klev,nqmx) |
---|
| 11 | integer nmicro |
---|
| 12 | c --------- |
---|
| 13 | |
---|
| 14 | PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1) |
---|
| 15 | PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25) |
---|
| 16 | |
---|
| 17 | COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL) |
---|
| 18 | |
---|
| 19 | COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL) |
---|
| 20 | & ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER) |
---|
| 21 | |
---|
| 22 | COMMON /STRATO/ C2H2(NLAYER),C2H6(NLAYER) |
---|
| 23 | COMMON /STRAT2/ HCN(NLAYER) |
---|
| 24 | |
---|
| 25 | COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER) |
---|
| 26 | & , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV) |
---|
| 27 | |
---|
| 28 | COMMON /CLOUD/ RADCLD(NLAYER), XNCLD(NLAYER) |
---|
| 29 | & , RCLDI(NSPECI), XICLDI(NSPECI), RCLDV(NSPECV), XICLDV(NSPECV) |
---|
| 30 | |
---|
| 31 | COMMON /TAUS/ TAUHI(klon,NSPECI),TAUCI(klon,NSPECI), |
---|
| 32 | & TAUGI(klon,NSPECI),TAURV(klon,NSPECV), |
---|
| 33 | & TAUHV(klon,NSPECV),TAUCV(klon,NSPECV), |
---|
| 34 | & TAUGV(klon,NSPECV) |
---|
| 35 | |
---|
| 36 | COMMON /TAUD/ TAUHID(klon,NLAYER,NSPECI) |
---|
| 37 | & ,TAUGID(klon,NLAYER,NSPECI) |
---|
| 38 | & ,TAUHVD(klon,NLAYER,NSPECV) |
---|
| 39 | & ,TAUGVD(klon,NLAYER,NSPECV) |
---|
| 40 | |
---|
| 41 | |
---|
| 42 | COMMON /OPTICI/ DTAUI(klon,NLAYER,NSPECI) |
---|
| 43 | & ,TAUI (klon,NLEVEL,NSPECI) |
---|
| 44 | & ,WBARI(klon,NLAYER,NSPECI) |
---|
| 45 | & ,COSBI(klon,NLAYER,NSPECI) |
---|
| 46 | |
---|
| 47 | COMMON /SPECTI/ BWNI(NSPC1I), WNOI(NSPECI), |
---|
| 48 | & DWNI(NSPECI), WLNI(NSPECI) |
---|
| 49 | |
---|
| 50 | COMMON /PLANT/ CSUBP,RSFI,RSFV,F0PI |
---|
| 51 | COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON |
---|
| 52 | COMMON /CONST/RGAS,RHOP,PI,SIGMA |
---|
| 53 | COMMON /traceurs/qaer |
---|
| 54 | COMMON /part/v,r,vrat,dr,dv |
---|
| 55 | |
---|
| 56 | DIMENSION PROD(NLEVEL) |
---|
| 57 | real qaer(klon,nlayer,nqmx) |
---|
| 58 | real v(nqmx),r(nqmx),vrat,dr(nqmx),dv(nqmx) |
---|
| 59 | real xv1(klev,nspeci),xv2(klev,nspeci) |
---|
| 60 | real xv3(klev,nspeci) |
---|
| 61 | REAL QF1(nqmx,NSPECI),QF2(nqmx,NSPECI) |
---|
| 62 | REAL QF3(nqmx,NSPECI),QF4(nqmx,NSPECI) |
---|
| 63 | REAL QM1(nqmx,NSPECI),QM2(nqmx,NSPECI) |
---|
| 64 | REAL QM3(nqmx,NSPECI),QM4(nqmx,NSPECI) |
---|
| 65 | real emu |
---|
| 66 | REAL TAEROSM1(NSPECI),TAEROSCATM1(NSPECI),DELTAZM1(NSPECI) |
---|
| 67 | |
---|
| 68 | save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4 |
---|
| 69 | |
---|
| 70 | integer iopti,iwarning |
---|
| 71 | integer ig_ |
---|
| 72 | save iopti,iwarning |
---|
| 73 | data iopti,iwarning/0,0/ |
---|
| 74 | |
---|
| 75 | C THE PRESSURE INDUCED TRANSITIONS ARE FROM REGIS |
---|
| 76 | C THE LAST SEVENTEEN INTERVALS ARE THE BANDS FROM GNF. |
---|
| 77 | C |
---|
| 78 | C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE INFRARED |
---|
| 79 | C IT CALCUALTES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE IR |
---|
| 80 | C LAYER: WBAR, DTAU, COSBAR |
---|
| 81 | C LEVEL: TAU |
---|
| 82 | C |
---|
| 83 | print*,'START OPTCI' |
---|
| 84 | c sum=0. |
---|
| 85 | c do nng=2,klon |
---|
| 86 | c do i=1,klev |
---|
| 87 | c do j=1,nqmx |
---|
| 88 | c print*,'j,rj',j,r(j) |
---|
| 89 | c print*,'paer',qaer(nng,i,j) |
---|
| 90 | c sum=sum+qaer(nng,i,j)*r(j)**3.*1.3333*3.1415*1000. |
---|
| 91 | c enddo |
---|
| 92 | c enddo |
---|
| 93 | c enddo |
---|
| 94 | c print*,sum/(klon-1),'SOMME COLONNE/OPTCI' |
---|
| 95 | |
---|
| 96 | |
---|
| 97 | c do inq=1,nqmx |
---|
| 98 | c print*,inq,r(inq),vrat,qaer(12,25,inq) |
---|
| 99 | c enddo |
---|
| 100 | |
---|
| 101 | DO 420 K=1,NSPECI |
---|
| 102 | C LETS USE THE THOLIN OPTICAL CONSTANTS FOR THE HAZE. |
---|
| 103 | CALL THOLIN(WLNI(K),TNR,TNI) |
---|
| 104 | REALI(K)=TNR |
---|
| 105 | XIMGI(K)=TNI*FHIR |
---|
| 106 | C SET UP THE OPTICAL CONSTANTS FOR THE CLOUD |
---|
| 107 | RCLDI(K)=1.27 |
---|
| 108 | XICLDI(K)=REFLIQ(WNOI(K)) |
---|
| 109 | 420 CONTINUE |
---|
| 110 | C |
---|
| 111 | C |
---|
| 112 | C ZERO ALL OPTICAL DEPTHS. |
---|
| 113 | C ??FLAG? FOR SOME APPLCIATIONS THE TOP OPACITY MAY NOT VANISH |
---|
| 114 | |
---|
| 115 | c open (unit=1,file='xsetupi') |
---|
| 116 | c do i=1,klev |
---|
| 117 | c read(1,*) a |
---|
| 118 | c do j=1,nspeci |
---|
| 119 | c read(1,*) xv1(i,j),xv2(i,j),xv3(i,j) |
---|
| 120 | c enddo |
---|
| 121 | c enddo |
---|
| 122 | c close(1) |
---|
| 123 | |
---|
| 124 | c************************************************************************ |
---|
| 125 | c************************************************************************ |
---|
| 126 | DO 79 ig=1,klon ! BOUCLE SUR GRILLE HORIZONTALE |
---|
| 127 | c print*,'ig NEW optci',ig |
---|
| 128 | c************************************************************************ |
---|
| 129 | c************************************************************************ |
---|
| 130 | |
---|
| 131 | DO 80 K=1,NSPECI |
---|
| 132 | TAUHI(ig,K)=0. |
---|
| 133 | TAUCI(ig,K)=0. |
---|
| 134 | TAUGI(ig,K)=0. |
---|
| 135 | 80 CONTINUE |
---|
| 136 | |
---|
| 137 | if (.not.ylellouch) then |
---|
| 138 | |
---|
| 139 | XN2(1) = ykim(ig,1,iradn2) |
---|
| 140 | CH4(1) = ykim(ig,1,iradch4) |
---|
| 141 | H2(1) = ykim(ig,1,iradh2) |
---|
| 142 | do j=2,nlayer |
---|
| 143 | XN2(j) = (ykim(ig,j,iradn2)+ykim(ig,j-1,iradn2))/2. |
---|
| 144 | CH4(j) = (ykim(ig,j,iradch4)+ykim(ig,j-1,iradch4))/2. |
---|
| 145 | H2(j) = (ykim(ig,j,iradh2)+ykim(ig,j-1,iradh2))/2. |
---|
| 146 | enddo |
---|
| 147 | XN2(nlevel) = ykim(ig,nlayer,iradn2) |
---|
| 148 | CH4(nlevel) = ykim(ig,nlayer,iradch4) |
---|
| 149 | H2(nlevel) = ykim(ig,nlayer,iradh2) |
---|
| 150 | |
---|
| 151 | do j=1,nlayer |
---|
| 152 | emu = ( xmu(j) + xmu(j+1) )/2. |
---|
| 153 | C2H2(j) = ykim(ig,j,iradc2h2) * 26./emu |
---|
| 154 | C2H6(j) = ykim(ig,j,iradc2h6) * 30./emu |
---|
| 155 | HCN(j) = ykim(ig,j,iradhcn ) * 27./emu |
---|
| 156 | enddo |
---|
| 157 | |
---|
| 158 | endif |
---|
| 159 | |
---|
| 160 | c************************************************************************ |
---|
| 161 | DO 100 J=1,NLAYER ! BOUCLE SUR L'ALTITUDE |
---|
| 162 | c************************************************************************ |
---|
| 163 | |
---|
| 164 | c print*,'ig,k,j ',ig,k,j |
---|
| 165 | |
---|
| 166 | C SET UP THE COEFFICIENT TO REDUCE MASS PATH TO STP ...SEE NOTES |
---|
| 167 | C T0 =273.15 PO=1.01325 BAR |
---|
| 168 | |
---|
| 169 | TBAR=0.5*(TEMP(J)+TEMP(J+1)) |
---|
| 170 | PBAR=SQRT(PRESS(J)*PRESS(J+1)) |
---|
| 171 | BMU=0.5*(XMU(J+1)+XMU(J)) |
---|
| 172 | COEF1=RGAS*273.15**2*.5E5* (PRESS(J+1)**2 - PRESS(J)**2) |
---|
| 173 | & /(1.01325**2 *EFFG(Z(J))*TBAR*BMU) |
---|
| 174 | |
---|
| 175 | IF (IPRINT .GT. 9) WRITE(6,21) J,EFFG(Z(J)),TBAR,BMU,COEF1 |
---|
| 176 | 21 FORMAT(' J, EFFG, TBAR, BMU, COEF1,: ',I3,1P6E10.3) |
---|
| 177 | |
---|
| 178 | c------------------------------------------------------------------------ |
---|
| 179 | DO 101 K=1,NSPECI ! BOUCLE SUR LES L.D'O |
---|
| 180 | c------------------------------------------------------------------------ |
---|
| 181 | |
---|
| 182 | |
---|
| 183 | C #1: HAZE |
---|
| 184 | C--------------------- |
---|
| 185 | |
---|
| 186 | C FIRST COMPUTE TAU AEROSOL |
---|
| 187 | |
---|
| 188 | |
---|
| 189 | c |
---|
| 190 | c /\ |
---|
| 191 | c / \ |
---|
| 192 | c / \ |
---|
| 193 | c / _O \ |
---|
| 194 | c / |/ \ |
---|
| 195 | c / / \ \ |
---|
| 196 | c / |\ \/\ \ |
---|
| 197 | c / || / \ \ |
---|
| 198 | c ---------------- |
---|
| 199 | c | WARNING | |
---|
| 200 | c | SLOW DOWN | |
---|
| 201 | c ---------------- |
---|
| 202 | |
---|
| 203 | |
---|
| 204 | |
---|
| 205 | |
---|
| 206 | c*********** EN TRAVAUX *************************** |
---|
| 207 | |
---|
| 208 | TAEROS=0. |
---|
| 209 | TAEROSCAT=0. |
---|
| 210 | CBAR=0. |
---|
| 211 | |
---|
| 212 | DO inq=1,nmicro !BOUCLE SUR LES NMICRO TAILLE D"AEROSOLS |
---|
| 213 | |
---|
| 214 | |
---|
| 215 | IF (WNOI(K).lt.wco) THEN ! lamda > 56 um |
---|
| 216 | |
---|
| 217 | if (iopti.eq.0) then |
---|
| 218 | |
---|
| 219 | c CALL XMIE(R(inq)*1.e6,REALI(K),XIMGI(K), |
---|
| 220 | c & QEXT,QSCT,QABS,QBAR,WNOI(K)) |
---|
| 221 | |
---|
| 222 | |
---|
| 223 | CALL CMIE(1.E-2/WNOI(K),REALI(K),XIMGI(K),R(inq), |
---|
| 224 | & QEXT,QSCT,QABS,QBAR) |
---|
| 225 | |
---|
| 226 | |
---|
| 227 | QM1(inq,K)=QEXT |
---|
| 228 | QM2(inq,K)=QSCT |
---|
| 229 | QM3(inq,K)=QABS |
---|
| 230 | QM4(inq,K)=QBAR |
---|
| 231 | |
---|
| 232 | endif ! end iopti |
---|
| 233 | |
---|
| 234 | |
---|
| 235 | if (microfi.eq.1) then |
---|
| 236 | ig_=ig |
---|
| 237 | else |
---|
| 238 | ig_=12 |
---|
| 239 | endif |
---|
| 240 | |
---|
| 241 | |
---|
| 242 | TAEROS=QM1(inq,K)*qaer(ig_,nlayer+1-J,inq)*1.e-4+TAEROS |
---|
| 243 | TAEROSCAT=QM2(inq,K)*qaer(ig_,nlayer+1-J,inq)*1.e-4+TAEROSCAT |
---|
| 244 | CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*qaer(ig_,nlayer+1-J,inq)*1.e-4 |
---|
| 245 | |
---|
| 246 | |
---|
| 247 | ELSE ! 0.2 < lambda < 56 um |
---|
| 248 | |
---|
| 249 | |
---|
| 250 | if(R(inq).lt.RF(inq)) THEN |
---|
| 251 | |
---|
| 252 | if (iopti.eq.0) then |
---|
| 253 | |
---|
| 254 | CALL XMIE(R(inq)*1.e6,REALI(K),XIMGI(K), |
---|
| 255 | & QEXT,QSCT,QABS,QBAR,WNOI(K)) |
---|
| 256 | |
---|
| 257 | QM1(inq,K)=QEXT |
---|
| 258 | QM2(inq,K)=QSCT |
---|
| 259 | QM3(inq,K)=QABS |
---|
| 260 | QM4(inq,K)=QBAR |
---|
| 261 | |
---|
| 262 | endif |
---|
| 263 | |
---|
| 264 | if (microfi.eq.1) then |
---|
| 265 | ig_=ig |
---|
| 266 | else |
---|
| 267 | ig_=12 |
---|
| 268 | endif |
---|
| 269 | |
---|
| 270 | |
---|
| 271 | TAEROS=QM1(inq,K)*qaer(ig_,nlayer+1-J,inq)*1.e-4+TAEROS |
---|
| 272 | TAEROSCAT=QM2(inq,K)*qaer(ig_,nlayer+1-J,inq)*1.e-4+TAEROSCAT |
---|
| 273 | CBAR=CBAR+QM4(inq,K)*QM2(inq,K)*qaer(ig_,nlayer+1-J,inq)*1.e-4 |
---|
| 274 | |
---|
| 275 | else |
---|
| 276 | |
---|
| 277 | XMONO=(r(inq)/RF(inq))**3. |
---|
| 278 | XRULE=1. |
---|
| 279 | |
---|
| 280 | if(XMONO.gt.16384./1.5) then |
---|
| 281 | XRULE=(XMONO/16384.) |
---|
| 282 | XMONO=16384. |
---|
| 283 | endif |
---|
| 284 | |
---|
| 285 | |
---|
| 286 | if (iopti.eq.0) then |
---|
| 287 | |
---|
| 288 | CALL OPTFRAC(XMONO,10000./WNOI(K) |
---|
| 289 | & ,QEXT,QSCT,QABS,QBAR) |
---|
| 290 | |
---|
| 291 | |
---|
| 292 | c CALL CFFFV11(1.e-2/WNOI(K),REALI(K),XIMGI(K),RF(inq),2. |
---|
| 293 | c & ,XMONO,QSCT,QEXT,QABS,QBAR) |
---|
| 294 | |
---|
| 295 | |
---|
| 296 | QF1(inq,K)=QEXT*XRULE |
---|
| 297 | QF2(inq,K)=QSCT*XRULE |
---|
| 298 | QF3(inq,K)=QABS*XRULE |
---|
| 299 | QF4(inq,K)=QBAR |
---|
| 300 | |
---|
| 301 | endif |
---|
| 302 | |
---|
| 303 | if (microfi.eq.1) then |
---|
| 304 | ig_=ig |
---|
| 305 | else |
---|
| 306 | ig_=12 |
---|
| 307 | endif |
---|
| 308 | |
---|
| 309 | TAEROS=QF1(inq,K)*qaer(ig_,nlayer+1-J,inq)+TAEROS |
---|
| 310 | TAEROSCAT=QF2(inq,K)*qaer(ig_,nlayer+1-J,inq)+TAEROSCAT |
---|
| 311 | CBAR=CBAR+QF4(inq,K)*QF2(inq,K)*qaer(ig_,nlayer+1-J,inq) |
---|
| 312 | |
---|
| 313 | endif |
---|
| 314 | |
---|
| 315 | IF(TAEROS.LT.1.e-10) TAEROS=1.e-10 |
---|
| 316 | |
---|
| 317 | ENDIF |
---|
| 318 | ENDDO ! FIN DE LA BOUCLE SUR NMICRO |
---|
| 319 | |
---|
| 320 | |
---|
| 321 | |
---|
| 322 | |
---|
| 323 | CBAR=CBAR/TAEROSCAT |
---|
| 324 | |
---|
| 325 | DELTAZ=Z(J)-Z(J+1) |
---|
| 326 | |
---|
| 327 | c -------------------------------------------------------------------- |
---|
| 328 | c profil brume Pascal: fit T (sauf tropopause) et albedo |
---|
| 329 | c ------------------- |
---|
| 330 | if( cutoff.eq.1) then |
---|
| 331 | IF(PRESS(J).gt.9.e-3) THEN |
---|
| 332 | TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*0.85 |
---|
| 333 | TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*0.85 |
---|
| 334 | c TAEROS=0. |
---|
| 335 | c TAEROSCAT=0. |
---|
| 336 | ENDIF |
---|
| 337 | |
---|
| 338 | IF(PRESS(J).gt.1.e-1) THEN |
---|
| 339 | TAEROS=TAEROSM1(K)*DELTAZ/DELTAZM1(K)*1.15 |
---|
| 340 | TAEROSCAT=TAEROSCATM1(K)*DELTAZ/DELTAZM1(K)*1.15 |
---|
| 341 | c TAEROS=0. |
---|
| 342 | c TAEROSCAT=0. |
---|
| 343 | ENDIF |
---|
| 344 | endif !cutoff=1 |
---|
| 345 | |
---|
| 346 | c profil brume pour fit T (y compris tropopause), mais ne fit plus albedo... |
---|
| 347 | c ----------------------- |
---|
| 348 | if( cutoff.eq.2) then |
---|
| 349 | IF(PRESS(J).gt.1.e-1) THEN |
---|
| 350 | TAEROS=0. |
---|
| 351 | TAEROSCAT=0. |
---|
| 352 | ENDIF |
---|
| 353 | endif !cutoff=2 |
---|
| 354 | c -------------------------------------------------------------------- |
---|
| 355 | |
---|
| 356 | TAEROSM1(K)=TAEROS |
---|
| 357 | TAEROSCATM1(K)=TAEROSCAT |
---|
| 358 | DELTAZM1(K)=DELTAZ |
---|
| 359 | |
---|
| 360 | |
---|
| 361 | IF(TAEROSCAT.le.0.) CBAR=0. |
---|
| 362 | |
---|
| 363 | c print*,'HERE, MCKAY AEROSOLS IR' |
---|
| 364 | c TAEROS=xv1(j,k) |
---|
| 365 | c TAEROSCAT=xv2(j,k) |
---|
| 366 | c CBAR=xv3(j,k) |
---|
| 367 | |
---|
| 368 | c if (ig.eq.1) then |
---|
| 369 | c if (k.eq.NSPECV/2) then |
---|
| 370 | c print*,'@IR',K,J,TAEROS,TAEROSCAT,CBAR |
---|
| 371 | c stop'Pour faire des comparaisons' |
---|
| 372 | c endif |
---|
| 373 | c endif |
---|
| 374 | |
---|
| 375 | |
---|
| 376 | c*********** EN TRAVAUX *************************** |
---|
| 377 | |
---|
| 378 | C #2: CLOUD |
---|
| 379 | C------------------ |
---|
| 380 | |
---|
| 381 | C NEXT COMPUTE TAU CLOUD |
---|
| 382 | TAUCLD=0.0 |
---|
| 383 | IF ( XNCLD(J) .GT. 0..and .taufac.gt.0.) THEN |
---|
| 384 | print*,'Appel a xmie avec radcld=',radcld(j) |
---|
| 385 | CALL XMIE(RADCLD(J),RCLDI(K),XICLDI(K), |
---|
| 386 | & QEXTC,QSCTC,QABSC,CBARC,WNOI(K)) |
---|
| 387 | TAUCLD=QEXTC*XNCLD(J) |
---|
| 388 | ENDIF |
---|
| 389 | |
---|
| 390 | |
---|
| 391 | C #3: GAZ |
---|
| 392 | C------------------ |
---|
| 393 | |
---|
| 394 | C NOW COMPUTE TAUGAS DUE TO THE PIA TERM ONLY FOR LAMDA LT 940 |
---|
| 395 | TAUGAS=0.0 |
---|
| 396 | IF (WNOI(K) .LT. 940. ) THEN |
---|
| 397 | c if(ig.eq.1.and.k.eq.nspecv/2) print*,'avant PIA' |
---|
| 398 | CALL PIA(K,TBAR,PNN,PCC,PCN,PHN) |
---|
| 399 | c if(ig.eq.1.and.k.eq.nspecv/2) print*,'apres PIA' |
---|
| 400 | C HERE IS WHERE WE COULD SCALE THE PIA COEFFICEINTS TO FIT DATA |
---|
| 401 | C BASED ON REGIS' NOTES. ---TGM HAS THIS ADJUST IN IT AS DEFAULT |
---|
| 402 | PCN=PCN*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) |
---|
| 403 | C***REPLACE ABOVE WITH: PCN=PCN*1.25*MIN(1.75 , AMAX1(1.0,WNOI(K)/200.)) |
---|
| 404 | C 1.25 FACTOR (NOT FROM DATA) SUGGESTED BY TOON et al. (1988) |
---|
| 405 | TAUGAS=COEF1* |
---|
| 406 | & (XN2(J)*XN2(J)*PNN + CH4(J)*CH4(J)*PCC |
---|
| 407 | & + XN2(J)*CH4(J)*PCN + XN2(J)*H2(J)*PHN) |
---|
| 408 | IF (J .EQ. NLAYER .AND. IPRINT .GT. 9) |
---|
| 409 | & WRITE (6,22) WNOI(K),TAUGAS,XN2(J),CH4(J),H2(J), |
---|
| 410 | & TBAR, PNN,PCC,PCN, PHN, |
---|
| 411 | & XN2(J)*XN2(J)*PNN , CH4(J)*CH4(J)*PCC , |
---|
| 412 | & XN2(J)*CH4(J)*PCN , XN2(J)*H2(J)*PHN |
---|
| 413 | 22 FORMAT(1X,1P8E10.2) |
---|
| 414 | ENDIF |
---|
| 415 | |
---|
| 416 | IF (K .GT. 28) THEN |
---|
| 417 | KGAS=K-28 |
---|
| 418 | C ??FLAG? HERE MUST BE WATCHED CAREFULLY |
---|
| 419 | U=COLDEN(J)*6.02204E23/BMU |
---|
| 420 | if(ig.eq.1.and.k.eq.nspecv/2) print*,'Avant GAS2' |
---|
| 421 | if((ylellouch).or.(.not.hcnrad)) then |
---|
| 422 | CALL GAS2_NOHCN(J, KGAS,TBAR,PBAR,U,TAU2) |
---|
| 423 | else |
---|
| 424 | CALL GAS2(J, KGAS,TBAR,PBAR,U,TAU2) |
---|
| 425 | endif |
---|
| 426 | if(ig.eq.1.and.k.eq.nspecv/2) print*,'Apres GAS2' |
---|
| 427 | TAUGAS=TAUGAS+TAU2 |
---|
| 428 | ENDIF |
---|
| 429 | C |
---|
| 430 | |
---|
| 431 | IF (TAEROS + TAUCLD .GT. 0.) THEN |
---|
| 432 | COSBI(ig,J,K)=(CBAR*TAEROSCAT + CBARC*TAUCLD ) |
---|
| 433 | & /(TAEROSCAT + TAUCLD) |
---|
| 434 | ELSE |
---|
| 435 | COSBI(ig,J,K)=0.0 |
---|
| 436 | ENDIF |
---|
| 437 | |
---|
| 438 | DTAUI(ig,J,K)=TAUGAS+TAEROS+TAUCLD |
---|
| 439 | |
---|
| 440 | TAUHI(ig,K)=TAUHI(ig,K) + TAEROS |
---|
| 441 | TAUHID(ig,J,K)=TAUHI(ig,K) |
---|
| 442 | |
---|
| 443 | TAUGI(ig,K)=TAUGI(ig,K) + TAUGAS |
---|
| 444 | TAUGID(ig,J,K)=TAUGI(ig,K) |
---|
| 445 | |
---|
| 446 | TAUCI(ig,K)=TAUCI(ig,K) + TAUCLD |
---|
| 447 | |
---|
| 448 | c if (ig.eq.1) then |
---|
| 449 | c if (k.eq.NSPECI/2.or.k.eq.1.or.k.eq.NSPECI) then |
---|
| 450 | c print*,'@IR',K,J,DTAUI(ig,J,K),TAUGAS,TAEROS,TAUCLD |
---|
| 451 | c endif |
---|
| 452 | c endif |
---|
| 453 | |
---|
| 454 | C ??FLAG? SERIOUS PROBLEM WITH THE CODE HERE! |
---|
| 455 | |
---|
| 456 | TLIMIT=1.E-16 |
---|
| 457 | |
---|
| 458 | IF (DTAUI(ig,J,K) .GT. TLIMIT) THEN |
---|
| 459 | |
---|
| 460 | c***************** ECHANGE |
---|
| 461 | c WBARI(J,K)=(QSCT*XNUMB(J) + QSCTC*XNCLD(J)) |
---|
| 462 | c**************** |
---|
| 463 | CFC WBARI(ig,J,K)=(TAEROSCAT + QSCTC*XNCLD(J)) |
---|
| 464 | c**************** |
---|
| 465 | WBARI(ig,J,K)=TAEROSCAT |
---|
| 466 | & /DTAUI(ig,J,K) |
---|
| 467 | if(iwarning.eq.0) |
---|
| 468 | s print*,'WARNING!!! dans optci xncld non initialise' |
---|
| 469 | iwarning=1 |
---|
| 470 | |
---|
| 471 | ELSE |
---|
| 472 | |
---|
| 473 | WBARI(ig,J,K)=0.0 |
---|
| 474 | c PRINT*,'gaz ',taugas,'aerosols',taeros,'nuages',taucld |
---|
| 475 | c WRITE (6,999) J,K,DTAUI(ig,J,K) |
---|
| 476 | 999 FORMAT (' WARNING TAU MINIMUM AT J,K,DTAU:',2I3,1PE10.3) |
---|
| 477 | DTAUI(ig,J,K)=TLIMIT |
---|
| 478 | |
---|
| 479 | ENDIF |
---|
| 480 | |
---|
| 481 | c IF (IPRINT .GT. 9) |
---|
| 482 | c & WRITE(6,73)J,K,TAUGAS,TAEROS,QEXT,QSCT |
---|
| 483 | 73 FORMAT(2I3,1P8E10.3) |
---|
| 484 | |
---|
| 485 | |
---|
| 486 | c------------------------------------------------------------------------ |
---|
| 487 | 101 CONTINUE ! FIN BOUCLE L D'O |
---|
| 488 | c------------------------------------------------------------------------ |
---|
| 489 | |
---|
| 490 | iopti=1 |
---|
| 491 | |
---|
| 492 | c************************************************************************ |
---|
| 493 | 100 CONTINUE ! FIN BOUCLE ALTITUDE |
---|
| 494 | c************************************************************************ |
---|
| 495 | |
---|
| 496 | c************************************************************************ |
---|
| 497 | c************************************************************************ |
---|
| 498 | 79 CONTINUE ! FIN BOUCLE GRILLE HORIZONTALE |
---|
| 499 | c************************************************************************ |
---|
| 500 | c************************************************************************ |
---|
| 501 | |
---|
| 502 | |
---|
| 503 | C TOTAL EXTINCTION OPTICAL DEPTHS |
---|
| 504 | |
---|
| 505 | DO 78 ig=1,klon ! #1 |
---|
| 506 | |
---|
| 507 | DO 119 K=1,NSPECI |
---|
| 508 | TAUI(ig,1,K)=0.0 |
---|
| 509 | DO 119 J=1,NLAYER |
---|
| 510 | TAUI(ig,J+1,K)=TAUI(ig,J,K)+DTAUI(ig,J,K) |
---|
| 511 | 119 CONTINUE |
---|
| 512 | |
---|
| 513 | IF (IPRINT .GT. 2) THEN |
---|
| 514 | c WRITE (6,120) |
---|
| 515 | 120 FORMAT(///' OPTICAL CONSTANTS IN THE INFRARED') |
---|
| 516 | |
---|
| 517 | c DO 200 K=1,NSPECI ! #2 |
---|
| 518 | c WRITE (6,190) |
---|
| 519 | c WRITE (6,210)K,WLNI(K),WNOI(K),BWNI(K) |
---|
| 520 | c & ,BWNI(K)+DWNI(K),DWNI(K) |
---|
| 521 | c WRITE (6,230)REALI(K),XIMGI(K) |
---|
| 522 | |
---|
| 523 | c DO 195 J=1,NLAYER ! #3 |
---|
| 524 | c WRITE (6,220)XNUMB(J), WBARI(ig,J,K),COSBI(ig,J,K) |
---|
| 525 | c & , DTAUI(ig,J,K),TAUI(ig,J,K) |
---|
| 526 | c 195 CONTINUE |
---|
| 527 | |
---|
| 528 | c IF(ig.eq.12) WRITE (6,240) TAUI(ig,NLEVEL,K) |
---|
| 529 | c 200 CONTINUE |
---|
| 530 | |
---|
| 531 | END IF |
---|
| 532 | 78 CONTINUE |
---|
| 533 | |
---|
| 534 | print*,"TAUI(1400,:,10)=",TAUI(1400,:,10) |
---|
| 535 | print*,"DTAUI(1400,:,10)=",DTAUI(1400,:,10) |
---|
| 536 | |
---|
| 537 | |
---|
| 538 | 210 FORMAT(1X,I3,F10.3,F10.2,F10.2,'-',F8.2,F10.3) |
---|
| 539 | 190 FORMAT(1X//' SNUM MICRONS WAVENU INTERVAL DELTA-WN') |
---|
| 540 | 230 FORMAT(1X,'NREAL(LAYER)= ',1PE10.3,' NIMG(LAYER)= ',E10.3/ |
---|
| 541 | &' #AEROSOLS WBAR COSBAR DTAU TAU') |
---|
| 542 | 220 FORMAT(5(1X,G9.3)) |
---|
| 543 | 240 FORMAT(41X,G9.3) |
---|
| 544 | |
---|
| 545 | c iopti=1 |
---|
| 546 | print*, 'FIN OPTCI' |
---|
| 547 | stop |
---|
| 548 | RETURN |
---|
| 549 | END |
---|